thread3.0.1/0000755003604700454610000000000014731057541011307 5ustar dgp771divthread3.0.1/lib/0000755003604700454610000000000014731057541012055 5ustar dgp771divthread3.0.1/lib/ttrace.tcl0000644003604700454610000005745414726633451014066 0ustar dgp771div# # ttrace.tcl -- # # Copyright (C) 2003 Zoran Vasiljevic, Archiware GmbH. All Rights Reserved. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # ---------------------------------------------------------------------------- # # User level commands: # # ttrace::eval top-level wrapper (ttrace-savvy eval) # ttrace::enable activates registered Tcl command traces # ttrace::disable terminates tracing of Tcl commands # ttrace::isenabled returns true if ttrace is enabled # ttrace::cleanup bring the interp to a pristine state # ttrace::update update interp to the latest trace epoch # ttrace::config setup some configuration options # ttrace::getscript returns a script for initializing interps # # Commands used for/from trace callbacks: # # ttrace::atenable register callback to be done at trace enable # ttrace::atdisable register callback to be done at trace disable # ttrace::addtrace register user-defined tracer callback # ttrace::addscript register user-defined script generator # ttrace::addresolver register user-defined command resolver # ttrace::addcleanup register user-defined cleanup procedures # ttrace::addentry adds one entry into the named trace store # ttrace::getentry returns the entry value from the named store # ttrace::delentry removes the entry from the named store # ttrace::getentries returns all entries from the named store # ttrace::preload register procedures to be preloaded always # # # Limitations: # # o. [namespace forget] is still not implemented # o. [namespace origin cmd] breaks if cmd is not already defined # # I left this deliberately. I didn't want to override the [namespace] # command in order to avoid potential slowdown. # namespace eval ttrace { # Setup some compatibility wrappers if {[info commands nsv_set] != ""} { variable tvers 0 variable mutex ns_mutex variable elock [$mutex create traceepochmutex] # Import the underlying API; faster than recomputing interp alias {} [namespace current]::_array {} nsv_array interp alias {} [namespace current]::_incr {} nsv_incr interp alias {} [namespace current]::_lappend {} nsv_lappend interp alias {} [namespace current]::_names {} nsv_names interp alias {} [namespace current]::_set {} nsv_set interp alias {} [namespace current]::_unset {} nsv_unset } elseif {![catch { variable tvers [package require thread] }]} { variable mutex thread::mutex variable elock [$mutex create] # Import the underlying API; faster than recomputing interp alias {} [namespace current]::_array {} tsv::array interp alias {} [namespace current]::_incr {} tsv::incr interp alias {} [namespace current]::_lappend {} tsv::lappend interp alias {} [namespace current]::_names {} tsv::names interp alias {} [namespace current]::_set {} tsv::set interp alias {} [namespace current]::_unset {} tsv::unset } else { error "requires NaviServer/AOLserver or Tcl threading extension" } # Keep in sync with the thread package package provide ttrace 3.0.1 package provide Ttrace 3.0.1 # Package variables variable resolvers "" ; # List of registered resolvers variable tracers "" ; # List of registered cmd tracers variable scripts "" ; # List of registered script makers variable enables "" ; # List of trace-enable callbacks variable disables "" ; # List of trace-disable callbacks variable preloads "" ; # List of procedure names to preload variable enabled 0 ; # True if trace is enabled variable config ; # Array with config options variable epoch -1 ; # The initialization epoch variable cleancnt 0 ; # Counter of registered cleaners # Package private namespaces namespace eval resolve "" ; # Commands for resolving commands namespace eval trace "" ; # Commands registered for tracing namespace eval enable "" ; # Commands invoked at trace enable namespace eval disable "" ; # Commands invoked at trace disable namespace eval script "" ; # Commands for generating scripts # Exported commands namespace export unknown # Initialize ttrace shared state if {[_array exists ttrace] == 0} { _set ttrace lastepoch $epoch _set ttrace epochlist "" } # Initially, allow creation of epochs set config(-doepochs) 1 proc eval {cmd args} { enable set code [catch {uplevel 1 [concat $cmd $args]} result] disable if {$code == 0} { if {[llength [info commands ns_ictl]]} { ns_ictl save [getscript] } else { thread::broadcast { package require ttrace ttrace::update } } } return -code $code \ -errorinfo $::errorInfo -errorcode $::errorCode $result } proc config {args} { variable config if {[llength $args] == 0} { array get config } elseif {[llength $args] == 1} { set opt [lindex $args 0] set config($opt) } else { set opt [lindex $args 0] set val [lindex $args 1] set config($opt) $val } } proc enable {} { variable config variable tracers variable enables variable enabled incr enabled 1 if {$enabled > 1} { return } if {$config(-doepochs) != 0} { variable epoch [_newepoch] } set nsp [namespace current] foreach enabler $enables { enable::_$enabler } foreach trace $tracers { if {[info commands $trace] != ""} { trace add execution $trace leave ${nsp}::trace::_$trace } } } proc disable {} { variable enabled variable tracers variable disables incr enabled -1 if {$enabled > 0} { return } set nsp [namespace current] foreach disabler $disables { disable::_$disabler } foreach trace $tracers { if {[info commands $trace] != ""} { trace remove execution $trace leave ${nsp}::trace::_$trace } } } proc isenabled {} { variable enabled expr {$enabled > 0} } proc update {{from -1}} { if {$from < 0} { variable epoch [_set ttrace lastepoch] } else { if {[lsearch [_set ttrace epochlist] $from] < 0} { error "no such epoch: $from" } variable epoch $from } uplevel 1 [getscript] } proc getscript {} { variable preloads variable epoch variable scripts append script [_serializensp] \n append script "::namespace eval [namespace current] {" \n append script "::namespace export unknown" \n append script "_useepoch $epoch" \n append script "}" \n foreach cmd $preloads { append script [_serializeproc $cmd] \n } foreach maker $scripts { append script [script::_$maker] } return $script } proc cleanup {args} { foreach cmd [info commands resolve::cleaner_*] { uplevel 1 $cmd $args } } proc preload {cmd} { variable preloads if {[lsearch $preloads $cmd] < 0} { lappend preloads $cmd } } proc atenable {cmd arglist body} { variable enables if {[lsearch $enables $cmd] < 0} { lappend enables $cmd set cmd [namespace current]::enable::_$cmd proc $cmd $arglist $body return $cmd } } proc atdisable {cmd arglist body} { variable disables if {[lsearch $disables $cmd] < 0} { lappend disables $cmd set cmd [namespace current]::disable::_$cmd proc $cmd $arglist $body return $cmd } } proc addtrace {cmd arglist body} { variable tracers if {[lsearch $tracers $cmd] < 0} { lappend tracers $cmd set tracer [namespace current]::trace::_$cmd proc $tracer $arglist $body if {[isenabled]} { trace add execution $cmd leave $tracer } return $tracer } } proc addscript {cmd body} { variable scripts if {[lsearch $scripts $cmd] < 0} { lappend scripts $cmd set cmd [namespace current]::script::_$cmd proc $cmd args $body return $cmd } } proc addresolver {cmd arglist body} { variable resolvers if {[lsearch $resolvers $cmd] < 0} { lappend resolvers $cmd set cmd [namespace current]::resolve::$cmd proc $cmd $arglist $body return $cmd } } proc addcleanup {body} { variable cleancnt set cmd [namespace current]::resolve::cleaner_[incr cleancnt] proc $cmd args $body return $cmd } proc addentry {cmd var val} { variable epoch _set ${epoch}-$cmd $var $val } proc delentry {cmd var} { variable epoch set ei $::errorInfo set ec $::errorCode catch {_unset ${epoch}-$cmd $var} set ::errorInfo $ei set ::errorCode $ec } proc getentry {cmd var} { variable epoch set ei $::errorInfo set ec $::errorCode if {[catch {_set ${epoch}-$cmd $var} val]} { set ::errorInfo $ei set ::errorCode $ec set val "" } return $val } proc getentries {cmd {pattern *}} { variable epoch _array names ${epoch}-$cmd $pattern } proc unknown {args} { set cmd [lindex $args 0] if {[uplevel 1 ttrace::_resolve [list $cmd]]} { set c [catch {uplevel 1 $cmd [lrange $args 1 end]} r] } else { set c [catch {uplevel 1 ::tcl::unknown $args} r] } return -code $c -errorcode $::errorCode -errorinfo $::errorInfo $r } proc _resolve {cmd} { variable resolvers foreach resolver $resolvers { if {[uplevel 1 [info comm resolve::$resolver] [list $cmd]]} { return 1 } } return 0 } proc _getthread {} { if {[info commands ns_thread] == ""} { thread::id } else { ns_thread getid } } proc _getthreads {} { if {[info commands ns_thread] == ""} { return [thread::names] } else { foreach entry [ns_info threads] { lappend threads [lindex $entry 2] } return $threads } } proc _newepoch {} { variable elock variable mutex $mutex lock $elock set old [_set ttrace lastepoch] set new [_incr ttrace lastepoch] _lappend ttrace $new [_getthread] if {$old >= 0} { _copyepoch $old $new _delepochs } _lappend ttrace epochlist $new $mutex unlock $elock return $new } proc _copyepoch {old new} { foreach var [_names $old-*] { set cmd [lindex [split $var -] 1] _array reset $new-$cmd [_array get $var] } } proc _delepochs {} { set tlist [_getthreads] set elist "" foreach epoch [_set ttrace epochlist] { if {[_dropepoch $epoch $tlist] == 0} { lappend elist $epoch } else { _unset ttrace $epoch } } _set ttrace epochlist $elist } proc _dropepoch {epoch threads} { set self [_getthread] foreach tid [_set ttrace $epoch] { if {$tid != $self && [lsearch $threads $tid] >= 0} { lappend alive $tid } } if {[info exists alive]} { _set ttrace $epoch $alive return 0 } else { foreach var [_names $epoch-*] { _unset $var } return 1 } } proc _useepoch {epoch} { if {$epoch >= 0} { set tid [_getthread] if {[lsearch [_set ttrace $epoch] $tid] == -1} { _lappend ttrace $epoch $tid } } } proc _serializeproc {cmd} { set dargs [info args $cmd] set pbody [info body $cmd] set pargs "" foreach arg $dargs { if {![info default $cmd $arg def]} { lappend pargs $arg } else { lappend pargs [list $arg $def] } } set nsp [namespace qual $cmd] if {$nsp == ""} { set nsp "::" } append res [list ::namespace eval $nsp] " {" \n append res [list ::proc [namespace tail $cmd] $pargs $pbody] \n append res "}" \n } proc _serializensp {{nsp ""} {result _}} { upvar $result res if {$nsp == ""} { set nsp [namespace current] } append res [list ::namespace eval $nsp] " {" \n foreach var [info vars ${nsp}::*] { set vname [namespace tail $var] if {[array exists $var] == 0} { append res [list ::variable $vname [set $var]] \n } else { append res [list ::variable $vname] \n append res [list ::array set $vname [array get $var]] \n } } foreach cmd [info procs ${nsp}::*] { append res [_serializeproc $cmd] \n } append res "}" \n foreach nn [namespace children $nsp] { _serializensp $nn res } return $res } } # # The code below is ment to be run once during the application start. It # provides implementation of tracing callbacks for some Tcl commands. Users # can supply their own tracer implementations on-the-fly. # # The code below will create traces for the following Tcl commands: # "namespace", "variable", "load", "proc" and "rename" # # Also, the Tcl object extension XOTcl 1.1.0 is handled and all XOTcl related # things, like classes and objects are traced (many thanks to Gustaf Neumann # from XOTcl for his kind help and support). # eval { # # Register the "load" trace. This will create the following key/value pair # in the "load" store: # # --- key ---- --- value --- # # # We normally need only the name_of_the_init_proc for being able to load # the package in other interpreters, but we store the path to the image # file as well. # ttrace::addtrace load {cmdline code args} { if {$code != 0} { return } set image [lindex $cmdline 1] set initp [lindex $cmdline 2] if {$initp == ""} { foreach pkg [info loaded] { if {[lindex $pkg 0] == $image} { set initp [lindex $pkg 1] } } } ttrace::addentry load $image $initp } ttrace::addscript load { append res "\n" foreach entry [ttrace::getentries load] { set initp [ttrace::getentry load $entry] append res "::load {} $initp" \n } return $res } # # Register the "namespace" trace. This will create the following key/value # entry in "namespace" store: # # --- key ---- --- value --- # ::fully::qualified::namespace 1 # # It will also fill the "proc" store for procedures and commands imported # in this namespace with following: # # --- key ---- --- value --- # ::fully::qualified::proc [list "" ""] # # The is the name of the namespace where the command or procedure is # imported from. # ttrace::addtrace namespace {cmdline code args} { if {$code != 0} { return } set nop [lindex $cmdline 1] set cns [uplevel 1 namespace current] if {$cns == "::"} { set cns "" } switch -glob $nop { eva* { set nsp [lindex $cmdline 2] if {![string match "::*" $nsp]} { set nsp ${cns}::$nsp } ttrace::addentry namespace $nsp 1 } imp* { # - parse import arguments (skip opt "-force") set opts [lrange $cmdline 2 end] if {[string match "-fo*" [lindex $opts 0]]} { set opts [lrange $cmdline 3 end] } # - register all imported procs and commands foreach opt $opts { if {![string match "::*" [::namespace qual $opt]]} { set opt ${cns}::$opt } # - first import procs foreach entry [ttrace::getentries proc $opt] { set cmd ${cns}::[::namespace tail $entry] set nsp [::namespace qual $entry] set done($cmd) 1 set entry [list 0 $nsp "" ""] ttrace::addentry proc $cmd $entry } # - then import commands foreach entry [info commands $opt] { set cmd ${cns}::[::namespace tail $entry] set nsp [::namespace qual $entry] if {[info exists done($cmd)] == 0} { set entry [list 0 $nsp "" ""] ttrace::addentry proc $cmd $entry } } } } } } ttrace::addscript namespace { append res \n foreach entry [ttrace::getentries namespace] { append res "::namespace eval $entry {}" \n } return $res } # # Register the "variable" trace. This will create the following key/value # entry in the "variable" store: # # --- key ---- --- value --- # ::fully::qualified::variable 1 # # The variable value itself is ignored at the time of # trace/collection. Instead, we take the real value at the time of script # generation. # ttrace::addtrace variable {cmdline code args} { if {$code != 0} { return } set opts [lrange $cmdline 1 end] if {[llength $opts]} { set cns [uplevel 1 namespace current] if {$cns == "::"} { set cns "" } foreach {var val} $opts { if {![string match "::*" $var]} { set var ${cns}::$var } ttrace::addentry variable $var 1 } } } ttrace::addscript variable { append res \n foreach entry [ttrace::getentries variable] { set cns [namespace qual $entry] set var [namespace tail $entry] append res "::namespace eval $cns {" \n append res "::variable $var" if {[array exists $entry]} { append res "\n::array set $var [list [array get $entry]]" \n } elseif {[info exists $entry]} { append res " [list [set $entry]]" \n } else { append res \n } append res "}" \n } return $res } # # Register the "rename" trace. It will create the following key/value pair # in "rename" store: # # --- key ---- --- value --- # ::fully::qualified::old ::fully::qualified::new # # The "new" value may be empty, for commands that have been deleted. In # such cases we also remove any traced procedure definitions. # ttrace::addtrace rename {cmdline code args} { if {$code != 0} { return } set cns [uplevel 1 namespace current] if {$cns == "::"} { set cns "" } set old [lindex $cmdline 1] if {![string match "::*" $old]} { set old ${cns}::$old } set new [lindex $cmdline 2] if {$new != ""} { if {![string match "::*" $new]} { set new ${cns}::$new } ttrace::addentry rename $old $new } else { ttrace::delentry proc $old } } ttrace::addscript rename { append res \n foreach old [ttrace::getentries rename] { set new [ttrace::getentry rename $old] append res "::rename $old {$new}" \n } return $res } # # Register the "proc" trace. This will create the following key/value pair # in the "proc" store: # # --- key ---- --- value --- # ::fully::qualified::proc [list ] # # The chages anytime one (re)defines a proc. The is the # namespace where the command was imported from. If empty, the # and will hold the actual procedure definition. See the # "namespace" tracer implementation also. # ttrace::addtrace proc {cmdline code args} { if {$code != 0} { return } set cns [uplevel 1 namespace current] if {$cns == "::"} { set cns "" } set cmd [lindex $cmdline 1] if {![string match "::*" $cmd]} { set cmd ${cns}::$cmd } set dargs [info args $cmd] set pbody [info body $cmd] set pargs "" foreach arg $dargs { if {![info default $cmd $arg def]} { lappend pargs $arg } else { lappend pargs [list $arg $def] } } set pdef [ttrace::getentry proc $cmd] if {$pdef == ""} { set epoch -1 ; # never traced before } else { set epoch [lindex $pdef 0] } ttrace::addentry proc $cmd [list [incr epoch] "" $pargs $pbody] } ttrace::addscript proc { return { if {[info command ::tcl::unknown] == ""} { rename ::unknown ::tcl::unknown namespace import -force ::ttrace::unknown } if {[info command ::tcl::info] == ""} { rename ::info ::tcl::info } proc ::info args { set cmd [lindex $args 0] set hit [lsearch -glob {commands procs args default body} $cmd*] if {$hit > 1} { if {[catch {uplevel 1 ::tcl::info $args}]} { uplevel 1 ttrace::_resolve [list [lindex $args 1]] } return [uplevel 1 ::tcl::info $args] } if {$hit == -1} { return [uplevel 1 ::tcl::info $args] } set cns [uplevel 1 namespace current] if {$cns == "::"} { set cns "" } set pat [lindex $args 1] if {![string match "::*" $pat]} { set pat ${cns}::$pat } set fns [ttrace::getentries proc $pat] if {[string match $cmd* commands]} { set fns [concat $fns [ttrace::getentries xotcl $pat]] } foreach entry $fns { if {$cns != [namespace qual $entry]} { set lazy($entry) 1 } else { set lazy([namespace tail $entry]) 1 } } foreach entry [uplevel 1 ::tcl::info $args] { set lazy($entry) 1 } array names lazy } } } # # Register procedure resolver. This will try to resolve the command in the # current namespace first, and if not found, in global namespace. It also # handles commands imported from other namespaces. # ttrace::addresolver resolveprocs {cmd {export 0}} { set cns [uplevel 1 namespace current] set name [namespace tail $cmd] if {$cns == "::"} { set cns "" } if {![string match "::*" $cmd]} { set ncmd ${cns}::$cmd set gcmd ::$cmd } else { set ncmd $cmd set gcmd $cmd } set pdef [ttrace::getentry proc $ncmd] if {$pdef == ""} { set pdef [ttrace::getentry proc $gcmd] if {$pdef == ""} { return 0 } set cmd $gcmd } else { set cmd $ncmd } set epoch [lindex $pdef 0] set pnsp [lindex $pdef 1] if {$pnsp != ""} { set nsp [namespace qual $cmd] if {$nsp == ""} { set nsp :: } set cmd ${pnsp}::$name if {[resolveprocs $cmd 1] == 0 && [info commands $cmd] == ""} { return 0 } namespace eval $nsp "namespace import -force $cmd" } else { uplevel 0 [list ::proc $cmd [lindex $pdef 2] [lindex $pdef 3]] if {$export} { set nsp [namespace qual $cmd] if {$nsp == ""} { set nsp :: } namespace eval $nsp "namespace export $name" } } variable resolveproc set resolveproc($cmd) $epoch return 1 } # # For XOTcl, the entire item introspection/tracing is delegated to XOTcl # itself. The xotcl store is filled with this: # # --- key ---- --- value --- # ::fully::qualified::item # # The is the script used to generate the entire item (class, # object). Note that we do not fill in this during code tracing. It is # done during the script generation. In this step, only the placeholder is # set. # # NOTE: we assume all XOTcl commands are imported in global namespace # ttrace::atenable XOTclEnabler {args} { if {[info commands ::xotcl::Class] == ""} { return } if {[info commands ::xotcl::_creator] == ""} { ::xotcl::Class create ::xotcl::_creator -instproc create {args} { set result [next] if {![string match ::xotcl::_* $result]} { ttrace::addentry xotcl $result "" } return $result } } ::xotcl::Class instmixin ::xotcl::_creator } ttrace::atdisable XOTclDisabler {args} { if { [info commands ::xotcl::Class] == "" || [info commands ::xotcl::_creator] == ""} { return } ::xotcl::Class instmixin "" ::xotcl::_creator destroy } set resolver [ttrace::addresolver resolveclasses {classname} { set cns [uplevel 1 namespace current] set script [ttrace::getentry xotcl $classname] if {$script == ""} { set name [namespace tail $classname] if {$cns == "::"} { set script [ttrace::getentry xotcl ::$name] } else { set script [ttrace::getentry xotcl ${cns}::$name] if {$script == ""} { set script [ttrace::getentry xotcl ::$name] } } if {$script == ""} { return 0 } } uplevel 1 [list namespace eval $cns $script] return 1 }] ttrace::addscript xotcl [subst -nocommands { if {![catch {Serializer new} ss]} { foreach entry [ttrace::getentries xotcl] { if {[ttrace::getentry xotcl \$entry] == ""} { ttrace::addentry xotcl \$entry [\$ss serialize \$entry] } } \$ss destroy return {::xotcl::Class proc __unknown name {$resolver \$name}} } }] # # Register callback to be called on cleanup. This will trash lazily loaded # procs which have changed since. # ttrace::addcleanup { variable resolveproc foreach cmd [array names resolveproc] { set def [ttrace::getentry proc $cmd] if {$def != ""} { set new [lindex $def 0] set old $resolveproc($cmd) if {[info command $cmd] != "" && $new != $old} { catch {rename $cmd ""} } } } } } # EOF return # Local Variables: # mode: tcl # fill-column: 78 # tab-width: 8 # indent-tabs-mode: nil # End: thread3.0.1/generic/0000755003604700454610000000000014731057541012723 5ustar dgp771divthread3.0.1/generic/threadSvListCmd.h0000644003604700454610000000111514726633451016136 0ustar dgp771div/* * Copyright (c) 2002 by Zoran Vasiljevic. * * See the file "license.txt" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * --------------------------------------------------------------------------- */ #ifndef _SV_LIST_H_ #define _SV_LIST_H_ MODULE_SCOPE void Sv_RegisterListCommands(); #endif /* _SV_LIST_H_ */ /* EOF $RCSfile: threadSvListCmd.h,v $ */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/threadSvListCmd.c0000644003604700454610000006374014726633451016145 0ustar dgp771div/* * Implementation of most standard Tcl list processing commands * suitable for operation on thread shared (list) variables. * * Copyright (c) 2002 by Zoran Vasiljevic. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * ---------------------------------------------------------------------------- */ #include "tclThreadInt.h" #include "threadSvCmd.h" #include "threadSvListCmd.h" /* * Implementation of list commands for shared variables. * Most of the standard Tcl list commands are implemented. * There are also two new commands: "lpop" and "lpush". * Those are very convenient for simple stack operations. * * Main difference to standard Tcl commands is that our commands * operate on list variable per-reference instead per-value. * This way we avoid frequent object shuffling between shared * containers and current interpreter, thus increasing speed. */ static Tcl_ObjCmdProc2 SvLpopObjCmd; /* lpop */ static Tcl_ObjCmdProc2 SvLpushObjCmd; /* lpush */ static Tcl_ObjCmdProc2 SvLappendObjCmd; /* lappend */ static Tcl_ObjCmdProc2 SvLreplaceObjCmd; /* lreplace */ static Tcl_ObjCmdProc2 SvLlengthObjCmd; /* llength */ static Tcl_ObjCmdProc2 SvLindexObjCmd; /* lindex */ static Tcl_ObjCmdProc2 SvLinsertObjCmd; /* linsert */ static Tcl_ObjCmdProc2 SvLrangeObjCmd; /* lrange */ static Tcl_ObjCmdProc2 SvLsearchObjCmd; /* lsearch */ static Tcl_ObjCmdProc2 SvLsetObjCmd; /* lset */ /* * Inefficient list duplicator function which, * however, produces deep list copies, unlike * the original, which just makes shallow copies. */ static void DupListObjShared(Tcl_Obj*, Tcl_Obj*); /* * This mutex protects a static variable which tracks * registration of commands and object types. */ static Tcl_Mutex initMutex; /* * Functions for implementing the "lset" list command */ static Tcl_Obj* SvLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size indexCount, Tcl_Obj **indexArray, Tcl_Obj *valuePtr); /* *----------------------------------------------------------------------------- * * Sv_RegisterListCommands -- * * Register list commands with shared variable module. * * Results: * A standard Tcl result. * * Side effects: * Memory gets allocated * *----------------------------------------------------------------------------- */ void Sv_RegisterListCommands(void) { static int initialized = 0; if (initialized == 0) { Tcl_MutexLock(&initMutex); if (initialized == 0) { /* Create list with 1 empty element. */ Tcl_Obj *listobj = Tcl_NewObj(); listobj = Tcl_NewListObj(1, &listobj); Sv_RegisterObjType(listobj->typePtr, DupListObjShared); Tcl_DecrRefCount(listobj); Sv_RegisterCommand("lpop", SvLpopObjCmd, NULL, 0); Sv_RegisterCommand("lpush", SvLpushObjCmd, NULL, 0); Sv_RegisterCommand("lappend", SvLappendObjCmd, NULL, 0); Sv_RegisterCommand("lreplace", SvLreplaceObjCmd, NULL, 0); Sv_RegisterCommand("linsert", SvLinsertObjCmd, NULL, 0); Sv_RegisterCommand("llength", SvLlengthObjCmd, NULL, 0); Sv_RegisterCommand("lindex", SvLindexObjCmd, NULL, 0); Sv_RegisterCommand("lrange", SvLrangeObjCmd, NULL, 0); Sv_RegisterCommand("lsearch", SvLsearchObjCmd, NULL, 0); Sv_RegisterCommand("lset", SvLsetObjCmd, NULL, 0); initialized = 1; } Tcl_MutexUnlock(&initMutex); } } /* *----------------------------------------------------------------------------- * * SvLpopObjCmd -- * * This procedure is invoked to process the "tsv::lpop" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvLpopObjCmd ( void *arg, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { int ret; Tcl_Size off, llen, index = 0, iarg = 0; Tcl_Obj *elPtr = NULL; Container *svObj = (Container*)arg; /* * Syntax: * tsv::lpop array key ?index? * $list lpop ?index? */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { return TCL_ERROR; } if (objc > 1 + off) { Tcl_WrongNumArgs(interp, off, objv, "?index?"); goto cmd_err; } if (objc == 1 + off) { iarg = off; } ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen); if (ret != TCL_OK) { goto cmd_err; } if (iarg) { ret = Tcl_GetIntForIndex(interp, objv[iarg], llen-1, &index); if (ret != TCL_OK) { goto cmd_err; } } if ((index < 0) || (index >= llen)) { /* Ignore out-of bounds, like Tcl does */ return Sv_PutContainer(interp, svObj, SV_UNCHANGED); } ret = Tcl_ListObjIndex(interp, svObj->tclObj, index, &elPtr); if (ret != TCL_OK) { goto cmd_err; } Tcl_IncrRefCount(elPtr); ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 1, 0, NULL); if (ret != TCL_OK) { Tcl_DecrRefCount(elPtr); goto cmd_err; } Tcl_SetObjResult(interp, elPtr); Tcl_DecrRefCount(elPtr); return Sv_PutContainer(interp, svObj, SV_CHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvLpushObjCmd -- * * This procedure is invoked to process the "tsv::lpush" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvLpushObjCmd ( void *arg, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { int ret, flg; Tcl_Size off, llen, index = 0; Tcl_Obj *args[1]; Container *svObj = (Container*)arg; /* * Syntax: * tsv::lpush array key element ?index? * $list lpush element ?index? */ flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); if (ret != TCL_OK) { return TCL_ERROR; } if (objc < 1 + off) { Tcl_WrongNumArgs(interp, off, objv, "element ?index?"); goto cmd_err; } ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen); if (ret != TCL_OK) { goto cmd_err; } if (objc == 2 + off) { ret = Tcl_GetIntForIndex(interp, objv[off+1], llen, &index); if (ret != TCL_OK) { goto cmd_err; } if (index < 0) { index = 0; } else if (index > llen) { index = llen; } } args[0] = Sv_DuplicateObj(objv[off]); ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 0, 1, args); if (ret != TCL_OK) { Tcl_DecrRefCount(args[0]); goto cmd_err; } return Sv_PutContainer(interp, svObj, SV_CHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvLappendObjCmd -- * * This procedure is invoked to process the "tsv::lappend" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvLappendObjCmd( void *arg, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { int ret, flg; Tcl_Size i, off; Tcl_Obj *dup; Container *svObj = (Container*)arg; /* * Syntax: * tsv::lappend array key value ?value ...? * $list lappend value ?value ...? */ flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); if (ret != TCL_OK) { return TCL_ERROR; } if (objc < 1 + off) { Tcl_WrongNumArgs(interp, off, objv, "value ?value ...?"); goto cmd_err; } for (i = off; i < objc; i++) { dup = Sv_DuplicateObj(objv[i]); ret = Tcl_ListObjAppendElement(interp, svObj->tclObj, dup); if (ret != TCL_OK) { Tcl_DecrRefCount(dup); goto cmd_err; } } Tcl_SetObjResult(interp, Sv_DuplicateObj(svObj->tclObj)); return Sv_PutContainer(interp, svObj, SV_CHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvLreplaceObjCmd -- * * This procedure is invoked to process the "tsv::lreplace" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvLreplaceObjCmd( void *arg, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { const char *firstArg; Tcl_Size off, llen, argLen, first, last, ndel, nargs, i, j; int ret; Tcl_Obj **args = NULL; Container *svObj = (Container*)arg; /* * Syntax: * tsv::lreplace array key first last ?element ...? * $list lreplace first last ?element ...? */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { return TCL_ERROR; } if (objc < 2 + off) { Tcl_WrongNumArgs(interp, off, objv, "first last ?element ...?"); goto cmd_err; } ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen); if (ret != TCL_OK) { goto cmd_err; } ret = Tcl_GetIntForIndex(interp, objv[off], llen-1, &first); if (ret != TCL_OK) { goto cmd_err; } ret = Tcl_GetIntForIndex(interp, objv[off+1], llen-1, &last); if (ret != TCL_OK) { goto cmd_err; } firstArg = Tcl_GetStringFromObj(objv[off], &argLen); if (first < 0) { first = 0; } if (llen && first >= llen && strncmp(firstArg, "end", argLen)) { Tcl_AppendResult(interp, "list doesn't have element ", firstArg, (void *)NULL); goto cmd_err; } if (last >= llen) { last = llen - 1; } if (first <= last) { ndel = last - first + 1; } else { ndel = 0; } nargs = objc - off - 2; if (nargs) { args = (Tcl_Obj**)Tcl_Alloc(nargs * sizeof(Tcl_Obj*)); for(i = off + 2, j = 0; i < objc; i++, j++) { args[j] = Sv_DuplicateObj(objv[i]); } } ret = Tcl_ListObjReplace(interp, svObj->tclObj, first, ndel, nargs, args); if (args) { if (ret != TCL_OK) { for(i = off + 2, j = 0; i < objc; i++, j++) { Tcl_DecrRefCount(args[j]); } } Tcl_Free(args); } return Sv_PutContainer(interp, svObj, SV_CHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvLrangeObjCmd -- * * This procedure is invoked to process the "tsv::lrange" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvLrangeObjCmd( void *arg, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { int ret; Tcl_Size first, last, i, off, llen, nargs, j; Tcl_Obj **elPtrs, **args; Container *svObj = (Container*)arg; /* * Syntax: * tsv::lrange array key first last * $list lrange first last */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { return TCL_ERROR; } if (objc != 2 + off) { Tcl_WrongNumArgs(interp, off, objv, "first last"); goto cmd_err; } ret = Tcl_ListObjGetElements(interp, svObj->tclObj, &llen, &elPtrs); if (ret != TCL_OK) { goto cmd_err; } ret = Tcl_GetIntForIndex(interp, objv[off], llen-1, &first); if (ret != TCL_OK) { goto cmd_err; } ret = Tcl_GetIntForIndex(interp, objv[off+1], llen-1, &last); if (ret != TCL_OK) { goto cmd_err; } if (first < 0) { first = 0; } if (last >= llen) { last = llen - 1; } if (first > last) { goto cmd_ok; } nargs = last - first + 1; args = (Tcl_Obj **)Tcl_Alloc(nargs * sizeof(Tcl_Obj *)); for (i = first, j = 0; i <= last; i++, j++) { args[j] = Sv_DuplicateObj(elPtrs[i]); } Tcl_ResetResult(interp); Tcl_SetListObj(Tcl_GetObjResult(interp), nargs, args); Tcl_Free(args); cmd_ok: return Sv_PutContainer(interp, svObj, SV_UNCHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvLinsertObjCmd -- * * This procedure is invoked to process the "tsv::linsert" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvLinsertObjCmd( void *arg, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { int ret, flg; Tcl_Size off, nargs, i, j, llen, index = 0; Tcl_Obj **args; Container *svObj = (Container*)arg; /* * Syntax: * tsv::linsert array key index element ?element ...? * $list linsert element ?element ...? */ flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); if (ret != TCL_OK) { return TCL_ERROR; } if (objc < 2 + off) { Tcl_WrongNumArgs(interp, off, objv, "index element ?element ...?"); goto cmd_err; } ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen); if (ret != TCL_OK) { goto cmd_err; } ret = Tcl_GetIntForIndex(interp, objv[off], llen, &index); if (ret != TCL_OK) { goto cmd_err; } if (index < 0) { index = 0; } else if (index > llen) { index = llen; } nargs = objc - off - 1; args = (Tcl_Obj **)Tcl_Alloc(nargs * sizeof(Tcl_Obj *)); for (i = off + 1, j = 0; i < objc; i++, j++) { args[j] = Sv_DuplicateObj(objv[i]); } ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 0, nargs, args); if (ret != TCL_OK) { for (i = off + 1, j = 0; i < objc; i++, j++) { Tcl_DecrRefCount(args[j]); } Tcl_Free(args); goto cmd_err; } Tcl_Free(args); return Sv_PutContainer(interp, svObj, SV_CHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvLlengthObjCmd -- * * This procedure is invoked to process the "tsv::llength" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvLlengthObjCmd( void *arg, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { Tcl_Size llen, off; int ret; Container *svObj = (Container*)arg; /* * Syntax: * tsv::llength array key * $list llength */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { return TCL_ERROR; } ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen); if (ret == TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewIntObj(llen)); } if (Sv_PutContainer(interp, svObj, SV_UNCHANGED) != TCL_OK) { return TCL_ERROR; } return ret; } /* *----------------------------------------------------------------------------- * * SvLsearchObjCmd -- * * This procedure is invoked to process the "tsv::lsearch" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvLsearchObjCmd( void *arg, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { int ret, match; Tcl_Size off, index, length, i, listc, imode, ipatt; const char *patBytes; Tcl_Obj **listv; Container *svObj = (Container*)arg; static const char *const modes[] = {"-exact", "-glob", "-regexp", NULL}; enum {LS_EXACT, LS_GLOB, LS_REGEXP} mode; mode = LS_GLOB; /* * Syntax: * tsv::lsearch array key ?mode? pattern * $list lsearch ?mode? pattern */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { return TCL_ERROR; } if (objc == 2 + off) { imode = off; ipatt = off + 1; } else if (objc == 1 + off) { imode = 0; ipatt = off; } else { Tcl_WrongNumArgs(interp, off, objv, "?mode? pattern"); goto cmd_err; } if (imode) { ret = Tcl_GetIndexFromObjStruct(interp, objv[imode], modes, sizeof(char *), "search mode", 0, &mode); if (ret != TCL_OK) { goto cmd_err; } } ret = Tcl_ListObjGetElements(interp, svObj->tclObj, &listc, &listv); if (ret != TCL_OK) { goto cmd_err; } index = TCL_INDEX_NONE; patBytes = Tcl_GetStringFromObj(objv[ipatt], &length); for (i = 0; i < listc; i++) { match = 0; switch (mode) { case LS_GLOB: match = Tcl_StringCaseMatch(Tcl_GetString(listv[i]), patBytes, 0); break; case LS_EXACT: { Tcl_Size len; const char *bytes = Tcl_GetStringFromObj(listv[i], &len); if (length == len) { match = (memcmp(bytes, patBytes, length) == 0); } break; } case LS_REGEXP: match = Tcl_RegExpMatchObj(interp, listv[i], objv[ipatt]); if (match < 0) { goto cmd_err; } break; } if (match) { index = i; break; } } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(index)); return Sv_PutContainer(interp, svObj, SV_UNCHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvLindexObjCmd -- * * This procedure is invoked to process the "tsv::lindex" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvLindexObjCmd( void *arg, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { Tcl_Obj **elPtrs; int ret; Tcl_Size llen, index, off; Container *svObj = (Container*)arg; /* * Syntax: * tsv::lindex array key index * $list lindex index */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { return TCL_ERROR; } if (objc != 1 + off) { Tcl_WrongNumArgs(interp, off, objv, "index"); goto cmd_err; } ret = Tcl_ListObjGetElements(interp, svObj->tclObj, &llen, &elPtrs); if (ret != TCL_OK) { goto cmd_err; } ret = Tcl_GetIntForIndex(interp, objv[off], llen-1, &index); if (ret != TCL_OK) { goto cmd_err; } if ((index >= 0) && (index < llen)) { Tcl_SetObjResult(interp, Sv_DuplicateObj(elPtrs[index])); } return Sv_PutContainer(interp, svObj, SV_UNCHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvLsetObjCmd -- * * This procedure is invoked to process the "tsv::lset" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvLsetObjCmd( void *arg, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { Tcl_Obj *lPtr; int ret; Tcl_Size argc, off; Container *svObj = (Container*)arg; /* * Syntax: * tsv::lset array key index ?index ...? value * $list lset index ?index ...? value */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { return TCL_ERROR; } if (objc < 2 + off) { Tcl_WrongNumArgs(interp, off, objv, "index ?index...? value"); goto cmd_err; } lPtr = svObj->tclObj; argc = objc - off - 1; if (!SvLsetFlat(interp, lPtr, argc, (Tcl_Obj**)objv+off,objv[objc-1])) { return TCL_ERROR; } Tcl_SetObjResult(interp, Sv_DuplicateObj(lPtr)); return Sv_PutContainer(interp, svObj, SV_CHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * DupListObjShared -- * * Help function to make a proper deep copy of the list object. * This is used as the replacement-hook for list object native * DupInternalRep function. We need it since the native function * does a shallow list copy, i.e. retains references to list * element objects from the original list. This gives us trouble * when making the list object shared between threads. * * Results: * None. * * Side effects; * This is not a very efficient implementation, but that's all what's * available to Tcl API programmer. We could include the tclInt.h and * get the copy more efficient using list internals, but ... * *----------------------------------------------------------------------------- */ static void DupListObjShared( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr /* Object with internal rep to set. */ ) { Tcl_Size i, llen; Tcl_Obj *elObj, **newObjList; Tcl_Obj *buf[16]; Tcl_ListObjLength(NULL, srcPtr, &llen); newObjList = (llen > 16) ? (Tcl_Obj**)Tcl_Alloc(llen*sizeof(Tcl_Obj *)) : &buf[0]; for (i = 0; i < llen; i++) { Tcl_ListObjIndex(NULL, srcPtr, i, &elObj); newObjList[i] = Sv_DuplicateObj(elObj); } Tcl_SetListObj(copyPtr, llen, newObjList); if (newObjList != &buf[0]) { Tcl_Free(newObjList); } } /* *---------------------------------------------------------------------- * * SvLsetFlat -- * * Almost exact copy from the TclLsetFlat found in tclListObj.c. * Simplified in a sense that thread shared objects are guaranteed * to be non-shared. * * Actual return value of this procedure is irrelevant to the caller, * and it should be either NULL or non-NULL. * *---------------------------------------------------------------------- */ static Tcl_Obj* SvLsetFlat( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *listPtr, /* Pointer to the list being modified */ Tcl_Size indexCount, /* Number of index args */ Tcl_Obj **indexArray, Tcl_Obj *valuePtr /* Value arg to 'lset' */ ) { Tcl_Size i, elemCount, index; int result; Tcl_Obj **elemPtrs; Tcl_Obj *pendingInvalidates[10]; /* Assumed max nesting depth */ Tcl_Obj **pendingInvalidatesPtr = pendingInvalidates; Tcl_Size numPendingInvalidates = 0; /* * Determine whether the index arg designates a list * or a single index. */ if (indexCount == 1 && Tcl_ListObjGetElements(interp, indexArray[0], &indexCount, &indexArray) != TCL_OK) { /* * Index arg designates something that is neither an index * nor a well formed list. */ return NULL; } /* * If there are no indices, then simply return the new value, * counting the returned pointer as a reference */ if (indexCount == 0) { return valuePtr; } /* Allocate if static array for pending invalidations is too small */ if (indexCount > (Tcl_Size)(sizeof(pendingInvalidates) / sizeof(pendingInvalidates[0]))) { pendingInvalidatesPtr = (Tcl_Obj **)Tcl_Alloc(indexCount * sizeof(*pendingInvalidatesPtr)); } /* * Handle each index arg by diving into the appropriate sublist */ for (i = 0; ; ++i) { /* * Take the sublist apart. */ result = Tcl_ListObjGetElements(interp,listPtr,&elemCount,&elemPtrs); if (result != TCL_OK) { break; } /* * Determine the index of the requested element. */ result = Tcl_GetIntForIndex(interp, indexArray[i], elemCount-1, &index); if (result != TCL_OK) { break; } /* * Check that the index is in range. */ if ((index < 0) || (index >= elemCount)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", TCL_INDEX_NONE)); result = TCL_ERROR; break; } /* * Remember list of Tcl_Objs that need invalidation of string reps. */ pendingInvalidatesPtr[numPendingInvalidates] = listPtr; ++numPendingInvalidates; /* * Break the loop after extracting the innermost sublist */ if (i + 1 >= indexCount) { result = TCL_OK; break; } listPtr = elemPtrs[index]; } /* * At this point listPtr holds the sublist (which could even be the * top level list) whose element is to be modified. */ if (result == TCL_OK) { result = Tcl_ListObjGetElements(interp,listPtr,&elemCount,&elemPtrs); if (result == TCL_OK) { Tcl_DecrRefCount(elemPtrs[index]); elemPtrs[index] = Sv_DuplicateObj(valuePtr); Tcl_IncrRefCount(elemPtrs[index]); } } if (result == TCL_OK) { /* * Since modification was successful, we need to invalidate string * representations of all ancestors of the modified sublist. */ while (numPendingInvalidates > 0) { --numPendingInvalidates; Tcl_InvalidateStringRep(pendingInvalidatesPtr[numPendingInvalidates]); } } if (pendingInvalidatesPtr != pendingInvalidates) { Tcl_Free(pendingInvalidatesPtr); } /* Note return only matters as non-NULL vs NULL */ return result == TCL_OK ? valuePtr : NULL; } /* EOF $RCSfile: threadSvListCmd.c,v $ */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/threadSvKeylistCmd.h0000644003604700454610000000125014726633451016647 0ustar dgp771div/* * threadSvKeylistCmd.h -- * * See the file "license.txt" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * --------------------------------------------------------------------------- */ #ifndef _KEYLISTCMDS_H_ #define _KEYLISTCMDS_H_ #include "tclThreadInt.h" MODULE_SCOPE void Sv_RegisterKeylistCommands(void); MODULE_SCOPE void TclX_KeyedListInit(Tcl_Interp *interp); #endif /* _KEYLISTCMDS_H_ */ /* EOF $RCSfile: threadSvKeylistCmd.h,v $ */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/threadSvKeylistCmd.c0000644003604700454610000002215314726633451016647 0ustar dgp771div/* * threadSvKeylist.c -- * * This file implements keyed-list commands as part of the thread * shared variable implementation. * * Keyed list implementation is borrowed from Mark Diekhans and * Karl Lehenbauer "TclX" (extended Tcl) extension. Please look * into the keylist.c file for more information. * * See the file "license.txt" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * --------------------------------------------------------------------------- */ #include "threadSvCmd.h" #include "threadSvKeylistCmd.h" #include "tclXkeylist.h" /* * Wrapped keyed-list commands */ static Tcl_ObjCmdProc2 SvKeylsetObjCmd; static Tcl_ObjCmdProc2 SvKeylgetObjCmd; static Tcl_ObjCmdProc2 SvKeyldelObjCmd; static Tcl_ObjCmdProc2 SvKeylkeysObjCmd; /* * This mutex protects a static variable which tracks * registration of commands and object types. */ static Tcl_Mutex initMutex; /* *----------------------------------------------------------------------------- * * Sv_RegisterKeylistCommands -- * * Register shared variable commands for TclX keyed lists. * * Results: * A standard Tcl result. * * Side effects: * Memory gets allocated * *----------------------------------------------------------------------------- */ void Sv_RegisterKeylistCommands(void) { static int initialized; if (initialized == 0) { Tcl_MutexLock(&initMutex); if (initialized == 0) { Sv_RegisterCommand("keylset", SvKeylsetObjCmd, NULL, 0); Sv_RegisterCommand("keylget", SvKeylgetObjCmd, NULL, 0); Sv_RegisterCommand("keyldel", SvKeyldelObjCmd, NULL, 0); Sv_RegisterCommand("keylkeys", SvKeylkeysObjCmd, NULL, 0); Sv_RegisterObjType(&keyedListType, DupKeyedListInternalRepShared); initialized = 1; } Tcl_MutexUnlock(&initMutex); } } /* *----------------------------------------------------------------------------- * * SvKeylsetObjCmd -- * * This procedure is invoked to process the "tsv::keylset" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvKeylsetObjCmd( void *arg, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { int ret, flg; Tcl_Size i, off; char *key; Tcl_Obj *val; Container *svObj = (Container*)arg; /* * Syntax: * sv::keylset array lkey key value ?key value ...? * $keylist keylset key value ?key value ...? */ flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); if (ret != TCL_OK) { return TCL_ERROR; } if (objc < 2 + off || ((objc - off) % 2)) { Tcl_WrongNumArgs(interp, off, objv, "key value ?key value ...?"); goto cmd_err; } for (i = off; i < objc; i += 2) { key = Tcl_GetString(objv[i]); val = Sv_DuplicateObj(objv[i+1]); ret = TclX_KeyedListSet(interp, svObj->tclObj, key, val); if (ret != TCL_OK) { goto cmd_err; } } return Sv_PutContainer(interp, svObj, SV_CHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvKeylgetObjCmd -- * * This procedure is invoked to process the "tsv::keylget" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvKeylgetObjCmd( void *arg, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { int ret, flg; Tcl_Size off; char *key; Tcl_Obj *varObjPtr = NULL, *valObjPtr = NULL; Container *svObj = (Container*)arg; /* * Syntax: * sv::keylget array lkey ?key? ?var? * $keylist keylget ?key? ?var? */ flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); if (ret != TCL_OK) { return TCL_ERROR; } if (objc > 2 + off) { Tcl_WrongNumArgs(interp, off, objv, "?key? ?var?"); goto cmd_err; } if (objc == off) { if (Sv_PutContainer(interp, svObj, SV_UNCHANGED) != TCL_OK) { return TCL_ERROR; } return SvKeylkeysObjCmd(arg, interp, objc, objv); } if (objc == 2 + off) { varObjPtr = objv[off+1]; } else { varObjPtr = NULL; } key = Tcl_GetString(objv[off]); ret = TclX_KeyedListGet(interp, svObj->tclObj, key, &valObjPtr); if (ret == TCL_ERROR) { goto cmd_err; } if (ret == TCL_BREAK) { if (varObjPtr) { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } else { Tcl_AppendResult (interp, "key \"", key, "\" not found", (void *)NULL); goto cmd_err; } } else { Tcl_Obj *resObjPtr = Sv_DuplicateObj(valObjPtr); if (varObjPtr) { Tcl_Size len; Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); Tcl_GetStringFromObj(varObjPtr, &len); if (len) { Tcl_ObjSetVar2(interp, varObjPtr, NULL, resObjPtr, 0); } } else { Tcl_SetObjResult(interp, resObjPtr); } } return Sv_PutContainer(interp, svObj, SV_UNCHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvKeyldelObjCmd -- * * This procedure is invoked to process the "tsv::keyldel" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvKeyldelObjCmd( void *arg, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_Size i, off; int ret; char *key; Container *svObj = (Container*)arg; /* * Syntax: * sv::keyldel array lkey key ?key ...? * $keylist keyldel ?key ...? */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { return TCL_ERROR; } if (objc < 1 + off) { Tcl_WrongNumArgs(interp, off, objv, "key ?key ...?"); goto cmd_err; } for (i = off; i < objc; i++) { key = Tcl_GetString(objv[i]); ret = TclX_KeyedListDelete(interp, svObj->tclObj, key); if (ret == TCL_BREAK) { Tcl_AppendResult(interp, "key \"", key, "\" not found", (void *)NULL); } if (ret == TCL_BREAK || ret == TCL_ERROR) { goto cmd_err; } } return Sv_PutContainer(interp, svObj, SV_CHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvKeylkeysObjCmd -- * * This procedure is invoked to process the "tsv::keylkeys" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvKeylkeysObjCmd( void *arg, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { int ret; Tcl_Size off; char *key = NULL; Tcl_Obj *listObj = NULL; Container *svObj = (Container*)arg; /* * Syntax: * sv::keylkeys array lkey ?key? * $keylist keylkeys ?key? */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { return TCL_ERROR; } if (objc > 1 + off) { Tcl_WrongNumArgs(interp, 1, objv, "?lkey?"); goto cmd_err; } if (objc == 1 + off) { key = Tcl_GetString(objv[off]); } ret = TclX_KeyedListGetKeys(interp, svObj->tclObj, key, &listObj); if (key && ret == TCL_BREAK) { Tcl_AppendResult(interp, "key \"", key, "\" not found", (void *)NULL); } if (ret == TCL_BREAK || ret == TCL_ERROR) { goto cmd_err; } Tcl_SetObjResult (interp, listObj); /* listObj allocated by API !*/ return Sv_PutContainer(interp, svObj, SV_UNCHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* EOF $RCSfile: threadSvKeylistCmd.c,v $ */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/threadSvCmd.h0000644003604700454610000001706514726633451015315 0ustar dgp771div/* * This is the header file for the module that implements shared variables. * for protected multithreaded access. * * Copyright (c) 2002 by Zoran Vasiljevic. * * See the file "license.txt" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * --------------------------------------------------------------------------- */ #ifndef _SV_H_ #define _SV_H_ #include #include #include #include "tclThreadInt.h" #include "threadSpCmd.h" /* For recursive locks */ /* * Uncomment following line to get command-line * compatibility with AOLserver nsv_* commands */ /* #define NSV_COMPAT 1 */ /* * Uncomment following line to force command-line * compatibility with older thread::sv_ commands. */ /* #define OLD_COMPAT 1 */ #ifdef NSV_COMPAT # define TSV_CMD2_PREFIX "nsv_" /* Compatiblity prefix for NaviServer/AOLserver */ #else # define TSV_CMD2_PREFIX "sv_" /* Regular command prefix for NaviServer/AOLserver */ #endif #ifdef OLD_COMPAT # define TSV_CMD_PREFIX "thread::sv_" /* Old command prefix for Tcl */ #else # define TSV_CMD_PREFIX "tsv::" /* Regular command prefix for Tcl */ #endif /* * Used when creating arrays/variables */ #define FLAGS_CREATEARRAY 1 /* Create the array in bucket if none found */ #define FLAGS_NOERRMSG 2 /* Do not format error message */ #define FLAGS_CREATEVAR 4 /* Create the array variable if none found */ /* * Macros for handling locking and unlocking */ #define LOCK_BUCKET(a) Sp_RecursiveMutexLock(&(a)->lock) #define UNLOCK_BUCKET(a) Sp_RecursiveMutexUnlock(&(a)->lock) #define LOCK_CONTAINER(a) Sp_RecursiveMutexLock(&(a)->bucketPtr->lock) #define UNLOCK_CONTAINER(a) Sp_RecursiveMutexUnlock(&(a)->bucketPtr->lock) /* * This is named synetrically to LockArray as function * rather than as a macro just to improve readability. */ #define UnlockArray(a) UNLOCK_CONTAINER(a) /* * Mode for Sv_PutContainer, so it knows what * happened with the embedded shared object. */ #define SV_UNCHANGED 0 /* Object has not been modified */ #define SV_CHANGED 1 /* Object has been modified */ #define SV_ERROR -1 /* Object may be in incosistent state */ /* * Definitions of functions implementing simple key/value * persistent storage for shared variable arrays. */ typedef void *(ps_open_proc)(const char*); typedef int (ps_get_proc) (void *, const char*, char**, Tcl_Size*); typedef int (ps_put_proc) (void *, const char*, char*, Tcl_Size); typedef int (ps_first_proc) (void *, char**, char**, Tcl_Size*); typedef int (ps_next_proc) (void *, char**, char**, Tcl_Size*); typedef int (ps_delete_proc)(void *, const char*); typedef int (ps_close_proc) (void *); typedef void(ps_free_proc) (void *, void*); typedef const char* (ps_geterr_proc)(void *); /* * This structure maintains a bunch of pointers to functions implementing * the simple persistence layer for the shared variable arrays. */ typedef struct PsStore { const char *type; /* Type identifier of the persistent storage */ void *psHandle; /* Handle to the opened storage */ ps_open_proc *psOpen; /* Function to open the persistent key store */ ps_get_proc *psGet; /* Function to retrieve value bound to key */ ps_put_proc *psPut; /* Function to store user key and value */ ps_first_proc *psFirst; /* Function to retrieve the first key/value */ ps_next_proc *psNext; /* Function to retrieve the next key/value */ ps_delete_proc *psDelete; /* Function to delete user key and value */ ps_close_proc *psClose; /* Function to close the persistent store */ ps_free_proc *psFree; /* Fuction to free allocated memory */ ps_geterr_proc *psError; /* Function to return last store error */ struct PsStore *nextPtr; /* For linking into linked lists */ } PsStore; /* * The following structure defines a collection of arrays. * Only the arrays within a given bucket share a lock, * allowing for more concurency. */ typedef struct Bucket { Sp_RecursiveMutex lock; /* */ Tcl_HashTable arrays; /* Hash table of all arrays in bucket */ Tcl_HashTable handles; /* Hash table of given-out handles in bucket */ struct Container *freeCt; /* List of free Tcl-object containers */ } Bucket; /* * The following structure maintains the context for each variable array. */ typedef struct Array { char *bindAddr; /* Array is bound to this address */ PsStore *psPtr; /* Persistent storage functions */ Bucket *bucketPtr; /* Array bucket. */ Tcl_HashEntry *entryPtr; /* Entry in bucket array table. */ Tcl_HashEntry *handlePtr; /* Entry in handles table */ Tcl_HashTable vars; /* Table of variables. */ } Array; /* * The object container for Tcl-objects stored within shared arrays. */ typedef struct Container { Bucket *bucketPtr; /* Bucket holding the array below */ Array *arrayPtr; /* Array with the object container*/ Tcl_HashEntry *entryPtr; /* Entry in array table. */ Tcl_HashEntry *handlePtr; /* Entry in handles table */ Tcl_Obj *tclObj; /* Tcl object to hold shared values */ Tcl_Size epoch; /* Track object changes */ char *chunkAddr; /* Address of one chunk of object containers */ struct Container *nextPtr; /* Next object container in the free list */ int aolSpecial; } Container; /* * Structure for generating command names in Tcl */ typedef struct SvCmdInfo { char *name; /* The short name of the command */ char *cmdName; /* Real (rewritten) name of the command */ char *cmdName2; /* Real AOL (rewritten) name of the command */ Tcl_ObjCmdProc2 *objProcPtr; /* The object-based command procedure */ Tcl_CmdDeleteProc *delProcPtr; /* Pointer to command delete function */ struct SvCmdInfo *nextPtr; /* Next in chain of registered commands */ int aolSpecial; } SvCmdInfo; /* * Structure for registering special object duplicator functions. * Reason for this is that even some regular Tcl duplicators * produce shallow instead of proper deep copies of the object. * While this is considered to be ok in single-threaded apps, * a multithreaded app could have problems when accessing objects * which live in (i.e. are accessed from) different interpreters. * So, for each object type which should be stored in shared object * pools, we must assure that the object is copied properly. */ typedef struct RegType { const Tcl_ObjType *typePtr; /* Type of the registered object */ Tcl_DupInternalRepProc *dupIntRepProc; /* Special deep-copy duper */ struct RegType *nextPtr; /* Next in chain of registered types */ } RegType; /* * Limited API functions */ MODULE_SCOPE void Sv_RegisterCommand(const char*,Tcl_ObjCmdProc2*,Tcl_CmdDeleteProc*, int); MODULE_SCOPE void Sv_RegisterObjType(const Tcl_ObjType*, Tcl_DupInternalRepProc*); MODULE_SCOPE void Sv_RegisterPsStore(const PsStore*); MODULE_SCOPE int Sv_GetContainer(Tcl_Interp*,Tcl_Size,Tcl_Obj*const objv[],Container**,Tcl_Size*,int); MODULE_SCOPE int Sv_PutContainer(Tcl_Interp*, Container*, int); /* * Private version of Tcl_DuplicateObj which takes care about * copying objects when loaded to and retrieved from shared array. */ MODULE_SCOPE Tcl_Obj* Sv_DuplicateObj(Tcl_Obj*); #endif /* _SV_H_ */ /* EOF $RCSfile: threadSvCmd.h,v $ */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/threadSvCmd.c0000644003604700454610000017552714726633451015320 0ustar dgp771div/* * This file implements a family of commands for sharing variables * between threads. * * Initial code is taken from nsd/tclvar.c found in AOLserver 3.+ * distribution and modified to support Tcl 8.0+ command object interface * and internal storage in private shared Tcl objects. * * Copyright (c) 2002 by Zoran Vasiljevic. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * ---------------------------------------------------------------------------- */ #include "tclThreadInt.h" #include "threadSvCmd.h" #include "threadSvListCmd.h" /* Shared variants of list commands */ #include "threadSvKeylistCmd.h" /* Shared variants of list commands */ #include "psGdbm.h" /* The gdbm persistent store implementation */ #include "psLmdb.h" /* The lmdb persistent store implementation */ #define SV_FINALIZE /* * Number of buckets to spread shared arrays into. Each bucket is * associated with one mutex so locking a bucket locks all arrays * in that bucket as well. The number of buckets should be a prime. */ #define NUMBUCKETS 31 /* * Number of object containers * to allocate in one shot. */ #define OBJS_TO_ALLOC_EACH_TIME 100 /* * Reference to Tcl object types used in object-copy code. * Those are referenced read-only, thus no mutex protection. */ static const Tcl_ObjType* booleanObjTypePtr = 0; static const Tcl_ObjType* byteArrayObjTypePtr = 0; static const Tcl_ObjType* doubleObjTypePtr = 0; static const Tcl_ObjType* intObjTypePtr = 0; static const Tcl_ObjType* wideIntObjTypePtr = 0; static const Tcl_ObjType* stringObjTypePtr = 0; /* * In order to be fully stub enabled, a small * hack is needed to query the tclEmptyStringRep * global symbol defined by Tcl. See SvInit. */ static char *Sv_tclEmptyStringRep = NULL; /* * Global variables used within this file. */ #ifdef SV_FINALIZE static size_t nofThreads; /* Number of initialized threads */ static Tcl_Mutex nofThreadsMutex; /* Protects the nofThreads variable */ #endif /* SV_FINALIZE */ static Bucket* buckets; /* Array of buckets. */ static Tcl_Mutex bucketsMutex; /* Protects the array of buckets */ static SvCmdInfo* svCmdInfo; /* Linked list of registered commands */ static RegType* regType; /* Linked list of registered obj types */ static PsStore* psStore; /* Linked list of registered pers. stores */ static Tcl_Mutex svMutex; /* Protects inserts into above lists */ static Tcl_Mutex initMutex; /* Serializes initialization issues */ /* * The standard commands found in NaviServer/AOLserver nsv_* interface. * For sharp-eye readers: the implementation of the "lappend" command * is moved to new list-command package, since it really belongs there. */ static Tcl_ObjCmdProc2 SvObjObjCmd; static Tcl_ObjCmdProc2 SvAppendObjCmd; static Tcl_ObjCmdProc2 SvIncrObjCmd; static Tcl_ObjCmdProc2 SvSetObjCmd; static Tcl_ObjCmdProc2 SvExistsObjCmd; static Tcl_ObjCmdProc2 SvGetObjCmd; static Tcl_ObjCmdProc2 SvArrayObjCmd; static Tcl_ObjCmdProc2 SvUnsetObjCmd; static Tcl_ObjCmdProc2 SvNamesObjCmd; static Tcl_ObjCmdProc2 SvHandlersObjCmd; /* * New commands added to * standard set of nsv_* */ static Tcl_ObjCmdProc2 SvPopObjCmd; static Tcl_ObjCmdProc2 SvMoveObjCmd; static Tcl_ObjCmdProc2 SvLockObjCmd; /* * Forward declarations for functions to * manage buckets, arrays and shared objects. */ static Container* CreateContainer(Array*, Tcl_HashEntry*, Tcl_Obj*); static Container* AcquireContainer(Array*, const char*, int); static Array* CreateArray(Bucket*, const char*); static Array* LockArray(Tcl_Interp*, const char*, int); static int ReleaseContainer(Tcl_Interp*, Container*, int); static int DeleteContainer(Container*); static int FlushArray(Array*); static int DeleteArray(Tcl_Interp *, Array*); static void SvAllocateContainers(Bucket*); static void SvRegisterStdCommands(void); #ifdef SV_FINALIZE static void SvFinalizeContainers(Bucket*); static void SvFinalize(void *); #endif /* SV_FINALIZE */ static PsStore* GetPsStore(const char *handle); static int SvObjDispatchObjCmd(void *arg, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* *----------------------------------------------------------------------------- * * Sv_RegisterCommand -- * * Utility to register commands to be loaded at module start. * * Results: * None. * * Side effects; * New command will be added to a linked list of registered commands. * *----------------------------------------------------------------------------- */ void Sv_RegisterCommand( const char *cmdName, /* Name of command to register */ Tcl_ObjCmdProc2 *objProc, /* Object-based command procedure */ Tcl_CmdDeleteProc *delProc, /* Command delete procedure */ int aolSpecial) { size_t len = strlen(cmdName) + strlen(TSV_CMD_PREFIX) + 1; size_t len2 = strlen(cmdName) + strlen(TSV_CMD2_PREFIX) + 1; SvCmdInfo *newCmd = (SvCmdInfo *)Tcl_Alloc(sizeof(SvCmdInfo) + len + len2); /* * Setup new command structure */ newCmd->cmdName = (char*)((char*)newCmd + sizeof(SvCmdInfo)); newCmd->cmdName2 = newCmd->cmdName + len; newCmd->aolSpecial = aolSpecial; newCmd->objProcPtr = objProc; newCmd->delProcPtr = delProc; /* * Rewrite command name. This is needed so we can * easily turn-on the compatiblity with NaviServer/AOLserver * command names. */ strcpy(newCmd->cmdName, TSV_CMD_PREFIX); strcat(newCmd->cmdName, cmdName); newCmd->name = newCmd->cmdName + strlen(TSV_CMD_PREFIX); strcpy(newCmd->cmdName2, TSV_CMD2_PREFIX); strcat(newCmd->cmdName2, cmdName); /* * Plug-in in shared list of commands. */ Tcl_MutexLock(&svMutex); if (svCmdInfo == NULL) { svCmdInfo = newCmd; newCmd->nextPtr = NULL; } else { newCmd->nextPtr = svCmdInfo; svCmdInfo = newCmd; } Tcl_MutexUnlock(&svMutex); return; } /* *----------------------------------------------------------------------------- * * Sv_RegisterObjType -- * * Registers custom object duplicator function for a specific * object type. Registered function will be called by the * private object creation routine every time an object is * plugged out or in the shared array. This way we assure that * Tcl objects do not get shared per-reference between threads. * * Results: * None. * * Side effects; * Memory gets allocated. * *----------------------------------------------------------------------------- */ void Sv_RegisterObjType( const Tcl_ObjType *typePtr, /* Type of object to register */ Tcl_DupInternalRepProc *dupProc) /* Custom object duplicator */ { RegType *newType = (RegType *)Tcl_Alloc(sizeof(RegType)); /* * Setup new type structure */ newType->typePtr = typePtr; newType->dupIntRepProc = dupProc; /* * Plug-in in shared list */ Tcl_MutexLock(&svMutex); newType->nextPtr = regType; regType = newType; Tcl_MutexUnlock(&svMutex); } /* *----------------------------------------------------------------------------- * * Sv_RegisterPsStore -- * * Registers a handler to the persistent storage. * * Results: * None. * * Side effects; * Memory gets allocated. * *----------------------------------------------------------------------------- */ void Sv_RegisterPsStore(const PsStore *psStorePtr) { PsStore *psPtr = (PsStore *)Tcl_Alloc(sizeof(PsStore)); *psPtr = *psStorePtr; /* * Plug-in in shared list */ Tcl_MutexLock(&svMutex); if (psStore == NULL) { psStore = psPtr; psStore->nextPtr = NULL; } else { psPtr->nextPtr = psStore; psStore = psPtr; } Tcl_MutexUnlock(&svMutex); } /* *----------------------------------------------------------------------------- * * Sv_GetContainer -- * * This is the workhorse of the module. It returns the container * with the shared Tcl object. It also locks the container, so * when finished with operation on the Tcl object, one has to * unlock the container by calling the Sv_PutContainer(). * If instructed, this command might also create new container * with empty Tcl object. * * Results: * A standard Tcl result. * * Side effects: * New container might be created. * *----------------------------------------------------------------------------- */ int Sv_GetContainer( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments */ Tcl_Obj *const objv[], /* Argument objects. */ Container **retObj, /* OUT: shared object container */ Tcl_Size *offset, /* Shift in argument list */ int flags) /* Options for locking shared array */ { const char *array, *key; if (*retObj == NULL) { Array *arrayPtr = NULL; /* * Parse mandatory arguments: array key */ if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "array key ?args?"); return TCL_ERROR; } array = Tcl_GetString(objv[1]); key = Tcl_GetString(objv[2]); *offset = 3; /* Consumed three arguments: cmd, array, key */ /* * Lock the shared array and locate the shared object */ arrayPtr = LockArray(interp, array, flags); if (arrayPtr == NULL) { return TCL_BREAK; } *retObj = AcquireContainer(arrayPtr, Tcl_GetString(objv[2]), flags); if (*retObj == NULL) { UnlockArray(arrayPtr); Tcl_AppendResult(interp, "no key ", array, "(", key, ")", (void *)NULL); return TCL_BREAK; } } else { Tcl_HashTable *handles = &((*retObj)->bucketPtr->handles); LOCK_CONTAINER(*retObj); if (Tcl_FindHashEntry(handles, (char*)(*retObj)) == NULL) { UNLOCK_CONTAINER(*retObj); Tcl_SetObjResult(interp, Tcl_NewStringObj("key has been deleted", TCL_INDEX_NONE)); return TCL_BREAK; } *offset = 2; /* Consumed two arguments: object, cmd */ } return TCL_OK; } /* *----------------------------------------------------------------------------- * * Sv_PutContainer -- * * Releases the container obtained by the Sv_GetContainer. * * Results: * A standard Tcl result. * * Side effects: * For bound arrays, update the underlying persistent storage. * *----------------------------------------------------------------------------- */ int Sv_PutContainer( Tcl_Interp *interp, /* For error reporting; might be NULL */ Container *svObj, /* Shared object container */ int mode) /* One of SV_XXX modes */ { int ret; ret = ReleaseContainer(interp, svObj, mode); UnlockArray(svObj->arrayPtr); return ret; } /* *----------------------------------------------------------------------------- * * GetPsStore -- * * Performs a lookup in the list of registered persistent storage * handlers. If the match is found, duplicates the persistent * storage record and passes the copy to the caller. * * Results: * Pointer to the newly allocated persistent storage handler. Caller * must free this block when done with it. If none found, returns NULL, * * Side effects; * Memory gets allocated. Caller should free the return value of this * function using Tcl_Free(). * *----------------------------------------------------------------------------- */ static PsStore* GetPsStore(const char *handle) { int i; const char *type = handle; char *addr, *delimiter = (char *)strchr(handle, ':'); PsStore *tmpPtr, *psPtr = NULL; /* * Expect the handle in the following format: :
* where "type" must match one of the registered presistent store * types (gdbm, tcl, whatever) and
is what is passed to * the open procedure of the registered store. * * Example: gdbm:/path/to/gdbm/file */ /* * Try to see wether some array is already bound to the * same persistent storage address. */ for (i = 0; i < NUMBUCKETS; i++) { Tcl_HashSearch search; Tcl_HashEntry *hPtr; Bucket *bucketPtr = &buckets[i]; LOCK_BUCKET(bucketPtr); hPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search); while (hPtr) { Array *arrayPtr = (Array*)Tcl_GetHashValue(hPtr); if (arrayPtr->bindAddr && arrayPtr->psPtr) { if (strcmp(arrayPtr->bindAddr, handle) == 0) { UNLOCK_BUCKET(bucketPtr); return NULL; /* Array already bound */ } } hPtr = Tcl_NextHashEntry(&search); } UNLOCK_BUCKET(bucketPtr); } /* * Split the address and storage handler */ if (delimiter == NULL) { addr = NULL; } else { *delimiter = 0; addr = delimiter + 1; } /* * No array was bound to the same persistent storage. * Lookup the persistent storage to bind to. */ Tcl_MutexLock(&svMutex); for (tmpPtr = psStore; tmpPtr; tmpPtr = tmpPtr->nextPtr) { if (strcmp(tmpPtr->type, type) == 0) { tmpPtr->psHandle = tmpPtr->psOpen(addr); if (tmpPtr->psHandle) { psPtr = (PsStore *)Tcl_Alloc(sizeof(PsStore)); *psPtr = *tmpPtr; psPtr->nextPtr = NULL; } break; } } Tcl_MutexUnlock(&svMutex); if (delimiter) { *delimiter = ':'; } return psPtr; } /* *----------------------------------------------------------------------------- * * AcquireContainer -- * * Finds a variable within an array and returns it's container. * * Results: * Pointer to variable object. * * Side effects; * New variable may be created. For bound arrays, try to locate * the key in the persistent storage as well. * *----------------------------------------------------------------------------- */ static Container * AcquireContainer( Array *arrayPtr, const char *key, int flags) { int isNew; Tcl_Obj *tclObj = NULL; Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&arrayPtr->vars, key); if (hPtr == NULL) { PsStore *psPtr = arrayPtr->psPtr; if (psPtr) { char *val = NULL; Tcl_Size len = 0; if (psPtr->psGet(psPtr->psHandle, key, &val, &len) == 0) { tclObj = Tcl_NewStringObj(val, len); psPtr->psFree(psPtr->psHandle, val); } } if (!(flags & FLAGS_CREATEVAR) && tclObj == NULL) { return NULL; } if (tclObj == NULL) { tclObj = Tcl_NewObj(); } hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &isNew); Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj)); } return (Container*)Tcl_GetHashValue(hPtr); } /* *----------------------------------------------------------------------------- * * ReleaseContainer -- * * Does some post-processing on the used container. This is mostly * needed when the container has been modified and needs to be * saved in the bound persistent storage. * * Results: * A standard Tcl result * * Side effects: * Persistent storage, if bound, might be modified. * *----------------------------------------------------------------------------- */ static int ReleaseContainer( Tcl_Interp *interp, Container *svObj, int mode) { const PsStore *psPtr = svObj->arrayPtr->psPtr; Tcl_Size len; char *key, *val; switch (mode) { case SV_UNCHANGED: return TCL_OK; case SV_ERROR: return TCL_ERROR; case SV_CHANGED: if (psPtr) { key = (char *)Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr); val = Tcl_GetStringFromObj(svObj->tclObj, &len); if (psPtr->psPut(psPtr->psHandle, key, val, len) == -1) { const char *err = psPtr->psError(psPtr->psHandle); Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE)); return TCL_ERROR; } } return TCL_OK; } return TCL_ERROR; /* Should never be reached */ } /* *----------------------------------------------------------------------------- * * CreateContainer -- * * Creates new shared container holding Tcl object to be stored * in the shared array * * Results: * The container pointer. * * Side effects: * Memory gets allocated. * *----------------------------------------------------------------------------- */ static Container * CreateContainer( Array *arrayPtr, Tcl_HashEntry *entryPtr, Tcl_Obj *tclObj) { Container *svObj; if (arrayPtr->bucketPtr->freeCt == NULL) { SvAllocateContainers(arrayPtr->bucketPtr); } svObj = arrayPtr->bucketPtr->freeCt; arrayPtr->bucketPtr->freeCt = svObj->nextPtr; svObj->arrayPtr = arrayPtr; svObj->bucketPtr = arrayPtr->bucketPtr; svObj->tclObj = tclObj; svObj->entryPtr = entryPtr; svObj->handlePtr = NULL; if (svObj->tclObj) { Tcl_IncrRefCount(svObj->tclObj); } return svObj; } /* *----------------------------------------------------------------------------- * * DeleteContainer -- * * Destroys the container and the Tcl object within it. For bound * shared arrays, the underlying persistent store is updated as well. * * Results: * None. * * Side effects: * Memory gets reclaimed. If the shared array was bound to persistent * storage, it removes the corresponding record. * *----------------------------------------------------------------------------- */ static int DeleteContainer( Container *svObj) { if (svObj->tclObj) { Tcl_DecrRefCount(svObj->tclObj); } if (svObj->handlePtr) { Tcl_DeleteHashEntry(svObj->handlePtr); } if (svObj->entryPtr) { PsStore *psPtr = svObj->arrayPtr->psPtr; if (psPtr) { char *key = (char *)Tcl_GetHashKey(&svObj->arrayPtr->vars,svObj->entryPtr); if (psPtr->psDelete(psPtr->psHandle, key) == -1) { return TCL_ERROR; } } Tcl_DeleteHashEntry(svObj->entryPtr); } svObj->arrayPtr = NULL; svObj->entryPtr = NULL; svObj->handlePtr = NULL; svObj->tclObj = NULL; svObj->nextPtr = svObj->bucketPtr->freeCt; svObj->bucketPtr->freeCt = svObj; return TCL_OK; } /* *----------------------------------------------------------------------------- * * LockArray -- * * Find (or create) the array structure for shared array and lock it. * Array structure must be later unlocked with UnlockArray. * * Results: * TCL_OK or TCL_ERROR if no such array. * * Side effects: * Sets *arrayPtrPtr with Array pointer or leave error in given interp. * *----------------------------------------------------------------------------- */ static Array * LockArray( Tcl_Interp *interp, /* Interpreter to leave result. */ const char *array, /* Name of array to lock */ int flags) /* FLAGS_CREATEARRAY/FLAGS_NOERRMSG*/ { const char *p; size_t result, i; Bucket *bucketPtr; Array *arrayPtr; /* * Compute a hash to map an array to a bucket. */ p = array; result = 0; while (*p++) { i = (unsigned char)*p; result += (result << 3) + i; } i = (result % NUMBUCKETS); bucketPtr = &buckets[i]; /* * Lock the bucket and find the array, or create a new one. * The bucket will be left locked on success. */ LOCK_BUCKET(bucketPtr); /* Note: no matching unlock below ! */ if (flags & FLAGS_CREATEARRAY) { arrayPtr = CreateArray(bucketPtr, array); } else { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&bucketPtr->arrays, array); if (hPtr == NULL) { UNLOCK_BUCKET(bucketPtr); if (!(flags & FLAGS_NOERRMSG)) { Tcl_AppendResult(interp, "\"", array, "\" is not a thread shared array", (void *)NULL); } return NULL; } arrayPtr = (Array*)Tcl_GetHashValue(hPtr); } return arrayPtr; } /* *----------------------------------------------------------------------------- * * FlushArray -- * * Unset all keys in an array. * * Results: * None. * * Side effects: * Array is cleaned but it's variable hash-hable still lives. * For bound arrays, the persistent store is updated accordingly. * *----------------------------------------------------------------------------- */ static int FlushArray(Array *arrayPtr) /* Name of array to flush */ { Tcl_HashEntry *hPtr; Tcl_HashSearch search; for (hPtr = Tcl_FirstHashEntry(&arrayPtr->vars, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { if (DeleteContainer((Container*)Tcl_GetHashValue(hPtr)) != TCL_OK) { return TCL_ERROR; } } return TCL_OK; } /* *----------------------------------------------------------------------------- * * CreateArray -- * * Creates new shared array instance. * * Results: * Pointer to the newly created array * * Side effects: * Memory gets allocated * *----------------------------------------------------------------------------- */ static Array * CreateArray( Bucket *bucketPtr, const char *arrayName) { int isNew; Array *arrayPtr; Tcl_HashEntry *hPtr; hPtr = Tcl_CreateHashEntry(&bucketPtr->arrays, arrayName, &isNew); if (!isNew) { return (Array*)Tcl_GetHashValue(hPtr); } arrayPtr = (Array *)Tcl_Alloc(sizeof(Array)); arrayPtr->bucketPtr = bucketPtr; arrayPtr->entryPtr = hPtr; arrayPtr->psPtr = NULL; arrayPtr->bindAddr = NULL; Tcl_InitHashTable(&arrayPtr->vars, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, arrayPtr); return arrayPtr; } /* *----------------------------------------------------------------------------- * * DeleteArray -- * * Deletes the shared array. * * Results: * A standard Tcl result. * * Side effects: * Memory gets reclaimed. * *----------------------------------------------------------------------------- */ static int UnbindArray(Tcl_Interp *interp, Array *arrayPtr) { PsStore *psPtr = arrayPtr->psPtr; if (arrayPtr->bindAddr) { Tcl_Free(arrayPtr->bindAddr); arrayPtr->bindAddr = NULL; } if (psPtr) { if (psPtr->psClose(psPtr->psHandle) == -1) { if (interp) { const char *err = psPtr->psError(psPtr->psHandle); Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE)); } return TCL_ERROR; } Tcl_Free(arrayPtr->psPtr), arrayPtr->psPtr = NULL; arrayPtr->psPtr = NULL; } return TCL_OK; } static int DeleteArray(Tcl_Interp *interp, Array *arrayPtr) { if (FlushArray(arrayPtr) == -1) { return TCL_ERROR; } if (arrayPtr->psPtr) { if (UnbindArray(interp, arrayPtr) != TCL_OK) { return TCL_ERROR; }; } if (arrayPtr->entryPtr) { Tcl_DeleteHashEntry(arrayPtr->entryPtr); } Tcl_DeleteHashTable(&arrayPtr->vars); Tcl_Free(arrayPtr); return TCL_OK; } /* *----------------------------------------------------------------------------- * * SvAllocateContainers -- * * Any similarity with the Tcl AllocateFreeObj function is purely * coincidental... Just joking; this is (almost) 100% copy of it! :-) * * Results: * None. * * Side effects: * Allocates memory for many containers at the same time * *----------------------------------------------------------------------------- */ static void SvAllocateContainers(Bucket *bucketPtr) { Container tmp[2]; size_t objSizePlusPadding = (size_t)(((char*)(tmp+1))-(char*)tmp); size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding); char *basePtr; Container *prevPtr = NULL, *objPtr = NULL; int i; basePtr = (char *)Tcl_Alloc(bytesToAlloc); memset(basePtr, 0, bytesToAlloc); objPtr = (Container*)basePtr; objPtr->chunkAddr = basePtr; /* Mark chunk address for reclaim */ for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { objPtr->nextPtr = prevPtr; prevPtr = objPtr; objPtr = (Container*)(((char*)objPtr) + objSizePlusPadding); } bucketPtr->freeCt = prevPtr; } #ifdef SV_FINALIZE /* *----------------------------------------------------------------------------- * * SvFinalizeContainers -- * * Reclaim memory for free object containers per bucket. * * Results: * None. * * Side effects: * Memory gets reclaimed * *----------------------------------------------------------------------------- */ static void SvFinalizeContainers(Bucket *bucketPtr) { Container *tmpPtr, *objPtr = bucketPtr->freeCt; while (objPtr) { if (objPtr->chunkAddr == (char*)objPtr) { tmpPtr = objPtr->nextPtr; Tcl_Free(objPtr); objPtr = tmpPtr; } else { objPtr = objPtr->nextPtr; } } } #endif /* SV_FINALIZE */ /* *----------------------------------------------------------------------------- * * Sv_DuplicateObj -- * * Create and return a new object that is (mostly) a duplicate of the * argument object. We take care that the duplicate object is either * a proper object copy, i.e. w/o hidden references to original object * elements or a plain string object, i.e one w/o internal representation. * * Decision about whether to produce a real duplicate or a string object * is done as follows: * * 1) Scalar Tcl object types are properly copied by default; * these include: boolean, int double, string and byteArray types. * 2) Object registered with Sv_RegisterObjType are duplicated * using custom duplicator function which is guaranteed to * produce a proper deep copy of the object in question. * 3) All other object types are stringified; these include * miscelaneous Tcl objects (cmdName, nsName, bytecode, etc, etc) * and all user-defined objects. * * Results: * The return value is a pointer to a newly created Tcl_Obj. This * object has reference count 0 and the same type, if any, as the * source object objPtr. Also: * * 1) If the source object has a valid string rep, we copy it; * otherwise, the new string rep is marked invalid. * 2) If the source object has an internal representation (i.e. its * typePtr is non-NULL), the new object's internal rep is set to * a copy; otherwise the new internal rep is marked invalid. * * Side effects: * Some object may, when copied, loose their type, i.e. will become * just plain string objects. * *----------------------------------------------------------------------------- */ Tcl_Obj * Sv_DuplicateObj( Tcl_Obj *objPtr /* The object to duplicate. */ ) { Tcl_Obj *dupPtr = Tcl_NewObj(); /* * Handle the internal rep */ if (objPtr->typePtr != NULL) { if (objPtr->typePtr->dupIntRepProc == NULL) { dupPtr->internalRep = objPtr->internalRep; dupPtr->typePtr = objPtr->typePtr; Tcl_InvalidateStringRep(dupPtr); } else { if ( objPtr->typePtr == booleanObjTypePtr \ || objPtr->typePtr == byteArrayObjTypePtr \ || objPtr->typePtr == doubleObjTypePtr \ || objPtr->typePtr == intObjTypePtr \ || objPtr->typePtr == wideIntObjTypePtr \ || objPtr->typePtr == stringObjTypePtr) { /* * Cover all "safe" obj types (see header comment) */ (*objPtr->typePtr->dupIntRepProc)(objPtr, dupPtr); if (dupPtr->typePtr != NULL) { Tcl_InvalidateStringRep(dupPtr); } } else { int found = 0; RegType *regPtr; /* * Cover special registered types. Assume not * very many of those, so this sequential walk * should be fast enough. */ for (regPtr = regType; regPtr; regPtr = regPtr->nextPtr) { if (objPtr->typePtr == regPtr->typePtr) { (*regPtr->dupIntRepProc)(objPtr, dupPtr); if (dupPtr->typePtr != NULL) { Tcl_InvalidateStringRep(dupPtr); } found = 1; break; } } /* * Assure at least string rep of the source * is present, which will be copied below. */ if (found == 0 && objPtr->bytes == NULL && objPtr->typePtr->updateStringProc != NULL) { (*objPtr->typePtr->updateStringProc)(objPtr); } } } } /* * Handle the string rep */ if (objPtr->bytes == NULL) { if (dupPtr->bytes != Sv_tclEmptyStringRep) { dupPtr->bytes = NULL; } } else if (objPtr->bytes != Sv_tclEmptyStringRep) { /* A copy of TclInitStringRep macro */ dupPtr->bytes = (char *)Tcl_Alloc(objPtr->length + 1); if (objPtr->length > 0) { memcpy(dupPtr->bytes, objPtr->bytes, objPtr->length); } dupPtr->length = objPtr->length; dupPtr->bytes[objPtr->length] = '\0'; } return dupPtr; } /* *----------------------------------------------------------------------------- * * SvObjDispatchObjCmd -- * * The method command for dispatching sub-commands of the shared * object. * * Results: * A standard Tcl result. * * Side effects: * Depends on the dispatched command * *----------------------------------------------------------------------------- */ static int SvObjDispatchObjCmd( void *arg, /* Pointer to object container. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *cmdName; SvCmdInfo *cmdPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "args"); return TCL_ERROR; } cmdName = Tcl_GetString(objv[1]); /* * Do simple linear search. We may later replace this list * with the hash table to gain speed. Currently, the list * of registered commands is so small, so this will work * fast enough. */ for (cmdPtr = svCmdInfo; cmdPtr; cmdPtr = cmdPtr->nextPtr) { if (!strcmp(cmdPtr->name, cmdName)) { return (*cmdPtr->objProcPtr)(arg, interp, objc, objv); } } Tcl_AppendResult(interp, "invalid command name \"", cmdName, "\"", (void *)NULL); return TCL_ERROR; } /* *----------------------------------------------------------------------------- * * SvObjObjCmd -- * * Creates the object command for a shared array. * * Results: * A standard Tcl result. * * Side effects: * New Tcl command gets created. * *----------------------------------------------------------------------------- */ static int SvObjObjCmd( void *arg, /* != NULL if aolSpecial */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int isNew, ret, flg; Tcl_Size off; char buf[128]; Tcl_Obj *val = NULL; Container *svObj = NULL; /* * Syntax: sv::object array key ?var? */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); switch (ret) { case TCL_BREAK: /* Shared array was not found */ if (objc != off) { val = objv[off]; } Tcl_ResetResult(interp); flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); if (ret != TCL_OK) { return TCL_ERROR; } Tcl_DecrRefCount(svObj->tclObj); svObj->tclObj = Sv_DuplicateObj(val ? val : Tcl_NewObj()); Tcl_IncrRefCount(svObj->tclObj); break; case TCL_ERROR: return TCL_ERROR; } if (svObj->handlePtr == NULL) { Tcl_HashTable *handles = &svObj->arrayPtr->bucketPtr->handles; svObj->handlePtr = Tcl_CreateHashEntry(handles, (char*)svObj, &isNew); } /* * Format the command name */ snprintf(buf, sizeof(buf), "::%p", svObj); svObj->aolSpecial = (arg != NULL); Tcl_CreateObjCommand2(interp, buf, SvObjDispatchObjCmd, svObj, NULL); Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_INDEX_NONE)); return Sv_PutContainer(interp, svObj, SV_UNCHANGED); } /* *----------------------------------------------------------------------------- * * SvArrayObjCmd -- * * This procedure is invoked to process the "tsv::array" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvArrayObjCmd( void *arg, /* Pointer to object container. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int ret = TCL_OK; Tcl_Size i, argx = 0, lobjc = 0; const char *arrayName = NULL; Array *arrayPtr = NULL; Tcl_Obj **lobjv = NULL; Container *svObj, *elObj = NULL; static const char *const opts[] = { "set", "reset", "get", "names", "size", "exists", "isbound", "bind", "unbind", NULL }; enum options { ASET, ARESET, AGET, ANAMES, ASIZE, AEXISTS, AISBOUND, ABIND, AUNBIND } index; svObj = (Container*)arg; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "option array"); return TCL_ERROR; } arrayName = Tcl_GetString(objv[2]); arrayPtr = LockArray(interp, arrayName, FLAGS_NOERRMSG); if (objc > 3) { argx = 3; } Tcl_ResetResult(interp); if (Tcl_GetIndexFromObjStruct(interp,objv[1],opts, sizeof(char *),"option",0,&index) != TCL_OK) { ret = TCL_ERROR; } else if (index == AEXISTS) { Tcl_SetIntObj(Tcl_GetObjResult(interp), arrayPtr!=0); } else if (index == AISBOUND) { if (arrayPtr == NULL) { Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); } else { Tcl_SetIntObj(Tcl_GetObjResult(interp), arrayPtr->psPtr!=0); } } else if (index == ASIZE) { if (arrayPtr == NULL) { Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); } else { Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (Tcl_WideInt)arrayPtr->vars.numEntries); } } else if (index == ASET || index == ARESET) { if (argx == (objc - 1)) { if (argx && Tcl_ListObjGetElements(interp, objv[argx], &lobjc, &lobjv) != TCL_OK) { ret = TCL_ERROR; goto cmdExit; } } else { lobjc = objc - 3; lobjv = (Tcl_Obj**)objv + 3; } if (lobjc & 1) { Tcl_AppendResult(interp, "list must have an even number" " of elements", (void *)NULL); ret = TCL_ERROR; goto cmdExit; } if (arrayPtr == NULL) { arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY); } if (index == ARESET) { ret = FlushArray(arrayPtr); if (ret != TCL_OK) { if (arrayPtr->psPtr) { PsStore *psPtr = arrayPtr->psPtr; const char *err = psPtr->psError(psPtr->psHandle); Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE)); } goto cmdExit; } } for (i = 0; i < lobjc; i += 2) { const char *key = Tcl_GetString(lobjv[i]); elObj = AcquireContainer(arrayPtr, key, FLAGS_CREATEVAR); Tcl_DecrRefCount(elObj->tclObj); elObj->tclObj = Sv_DuplicateObj(lobjv[i+1]); Tcl_IncrRefCount(elObj->tclObj); if (ReleaseContainer(interp, elObj, SV_CHANGED) != TCL_OK) { ret = TCL_ERROR; goto cmdExit; } } } else if (index == AGET || index == ANAMES) { if (arrayPtr) { Tcl_HashSearch search; Tcl_Obj *resObj = Tcl_NewListObj(0, NULL); const char *pattern = (argx == 0) ? NULL : Tcl_GetString(objv[argx]); Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search); while (hPtr) { char *key = (char *)Tcl_GetHashKey(&arrayPtr->vars, hPtr); if (pattern == NULL || Tcl_StringCaseMatch(key, pattern, 0)) { Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj(key, TCL_INDEX_NONE)); if (index == AGET) { elObj = (Container*)Tcl_GetHashValue(hPtr); Tcl_ListObjAppendElement(interp, resObj, Sv_DuplicateObj(elObj->tclObj)); } } hPtr = Tcl_NextHashEntry(&search); } Tcl_SetObjResult(interp, resObj); } } else if (index == ABIND) { /* * This is more complex operation, requiring some clarification. * * When binding an already existing array, we walk the array * first and store all key/value pairs found there in the * persistent storage. Then we proceed with the below. * * When binding an non-existent array, we open the persistent * storage and cache all key/value pairs found there into tne * newly created shared array. */ PsStore *psPtr; Tcl_HashEntry *hPtr; Tcl_Size len; int isNew; char *psurl, *key = NULL, *val = NULL; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "array handle"); ret = TCL_ERROR; goto cmdExit; } if (arrayPtr && arrayPtr->psPtr) { Tcl_AppendResult(interp, "array is already bound", (void *)NULL); ret = TCL_ERROR; goto cmdExit; } psurl = Tcl_GetStringFromObj(objv[3], &len); psPtr = GetPsStore(psurl); if (psPtr == NULL) { Tcl_AppendResult(interp, "can't open persistent storage on \"", psurl, "\"", (void *)NULL); ret = TCL_ERROR; goto cmdExit; } if (arrayPtr) { Tcl_HashSearch search; hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search); arrayPtr->psPtr = psPtr; arrayPtr->bindAddr = strcpy((char *)Tcl_Alloc(len+1), psurl); while (hPtr) { svObj = (Container *)Tcl_GetHashValue(hPtr); if (ReleaseContainer(interp, svObj, SV_CHANGED) != TCL_OK) { ret = TCL_ERROR; goto cmdExit; } hPtr = Tcl_NextHashEntry(&search); } } else { arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY); arrayPtr->psPtr = psPtr; arrayPtr->bindAddr = strcpy((char *)Tcl_Alloc(len+1), psurl); } if (!psPtr->psFirst(psPtr->psHandle, &key, &val, &len)) { do { Tcl_Obj * tclObj = Tcl_NewStringObj(val, len); hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &isNew); Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj)); psPtr->psFree(psPtr->psHandle, val); } while (!psPtr->psNext(psPtr->psHandle, &key, &val, &len)); } } else if (index == AUNBIND) { if (!arrayPtr || !arrayPtr->psPtr) { Tcl_AppendResult(interp, "shared variable is not bound", (void *)NULL); ret = TCL_ERROR; goto cmdExit; } if (UnbindArray(interp, arrayPtr) != TCL_OK) { ret = TCL_ERROR; goto cmdExit; } } cmdExit: if (arrayPtr) { UnlockArray(arrayPtr); } return ret; } /* *----------------------------------------------------------------------------- * * SvUnsetObjCmd -- * * This procedure is invoked to process the "tsv::unset" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvUnsetObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Size ii; const char *arrayName; Array *arrayPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "array ?key ...?"); return TCL_ERROR; } arrayName = Tcl_GetString(objv[1]); arrayPtr = LockArray(interp, arrayName, 0); if (arrayPtr == NULL) { return TCL_ERROR; } if (objc == 2) { UnlockArray(arrayPtr); if (DeleteArray(interp, arrayPtr) != TCL_OK) { return TCL_ERROR; } } else { for (ii = 2; ii < objc; ii++) { const char *key = Tcl_GetString(objv[ii]); Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&arrayPtr->vars, key); if (hPtr) { if (DeleteContainer((Container*)Tcl_GetHashValue(hPtr)) != TCL_OK) { UnlockArray(arrayPtr); return TCL_ERROR; } } else { UnlockArray(arrayPtr); Tcl_AppendResult(interp,"no key ",arrayName,"(",key,")",(void *)NULL); return TCL_ERROR; } } UnlockArray(arrayPtr); } return TCL_OK; } /* *----------------------------------------------------------------------------- * * SvNamesObjCmd -- * * This procedure is invoked to process the "tsv::names" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvNamesObjCmd( void *arg, /* != NULL if aolSpecial */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int i; const char *pattern = NULL; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Obj *resObj; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } if (objc == 2) { pattern = Tcl_GetString(objv[1]); } resObj = Tcl_NewListObj(0, NULL); for (i = 0; i < NUMBUCKETS; i++) { Bucket *bucketPtr = &buckets[i]; LOCK_BUCKET(bucketPtr); hPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search); while (hPtr) { char *key = (char *)Tcl_GetHashKey(&bucketPtr->arrays, hPtr); if ((arg==NULL || (*key != '.')) /* Hide . arrays for AOL*/ && (pattern == NULL || Tcl_StringCaseMatch(key, pattern, 0))) { Tcl_ListObjAppendElement(interp, resObj, Tcl_NewStringObj(key, TCL_INDEX_NONE)); } hPtr = Tcl_NextHashEntry(&search); } UNLOCK_BUCKET(bucketPtr); } Tcl_SetObjResult(interp, resObj); return TCL_OK; } /* *----------------------------------------------------------------------------- * * SvGetObjCmd -- * * This procedure is invoked to process "tsv::get" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvGetObjCmd( void *arg, /* Pointer to object container. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int ret; Tcl_Size off; Tcl_Obj *res; Container *svObj = (Container*)arg; /* * Syntax: * tsv::get array key ?var? * $object get ?var? */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); switch (ret) { case TCL_BREAK: if (objc == off) { return TCL_ERROR; } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); return TCL_OK; } case TCL_ERROR: return TCL_ERROR; } res = Sv_DuplicateObj(svObj->tclObj); if (objc == off) { Tcl_SetObjResult(interp, res); } else { if (Tcl_ObjSetVar2(interp, objv[off], NULL, res, 0) == NULL) { Tcl_DecrRefCount(res); goto cmd_err; } Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } return Sv_PutContainer(interp, svObj, SV_UNCHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvExistsObjCmd -- * * This procedure is invoked to process "tsv::exists" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvExistsObjCmd( void *arg, /* Pointer to object container. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Size off; int ret; Container *svObj = (Container*)arg; /* * Syntax: * tsv::exists array key * $object exists */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); switch (ret) { case TCL_BREAK: /* Array/key not found */ Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); return TCL_OK; case TCL_ERROR: return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); return Sv_PutContainer(interp, svObj, SV_UNCHANGED); } /* *----------------------------------------------------------------------------- * * SvSetObjCmd -- * * This procedure is invoked to process the "tsv::set" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvSetObjCmd( void *arg, /* Pointer to object container */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int ret, flg, mode; Tcl_Size off; Tcl_Obj *val; Container *svObj = (Container*)arg; /* * Syntax: * tsv::set array key ?value? * $object set ?value? */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); switch (ret) { case TCL_BREAK: if (objc == off) { return TCL_ERROR; } else { Tcl_ResetResult(interp); flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); if (ret != TCL_OK) { return TCL_ERROR; } } break; case TCL_ERROR: return TCL_ERROR; } if (objc != off) { val = objv[off]; Tcl_DecrRefCount(svObj->tclObj); svObj->tclObj = Sv_DuplicateObj(val); Tcl_IncrRefCount(svObj->tclObj); mode = SV_CHANGED; } else { val = Sv_DuplicateObj(svObj->tclObj); mode = SV_UNCHANGED; } Tcl_SetObjResult(interp, val); return Sv_PutContainer(interp, svObj, mode); } /* *----------------------------------------------------------------------------- * * SvIncrObjCmd -- * * This procedure is invoked to process the "tsv::incr" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvIncrObjCmd( void *arg, /* Pointer to object container */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int ret, flg, isNew = 0; Tcl_Size off; Tcl_WideInt incrValue = 1, currValue = 0; Container *svObj = (Container*)arg; /* * Syntax: * tsv::incr array key ?increment? * $object incr ?increment? */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { if (ret != TCL_BREAK) { return TCL_ERROR; } flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; Tcl_ResetResult(interp); ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); if (ret != TCL_OK) { return TCL_ERROR; } isNew = 1; } if ((objc != off)) { ret = Tcl_GetWideIntFromObj(interp, objv[off], &incrValue); if (ret != TCL_OK) { goto cmd_err; } } if (isNew) { currValue = 0; } else { ret = Tcl_GetWideIntFromObj(interp, svObj->tclObj, &currValue); if (ret != TCL_OK) { goto cmd_err; } } incrValue += currValue; Tcl_SetWideIntObj(svObj->tclObj, incrValue); Tcl_ResetResult(interp); Tcl_SetWideIntObj(Tcl_GetObjResult(interp), incrValue); return Sv_PutContainer(interp, svObj, SV_CHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvAppendObjCmd -- * * This procedure is invoked to process the "tsv::append" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvAppendObjCmd( void *arg, /* Pointer to object container */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int flg, ret; Tcl_Size i, off; Container *svObj = (Container*)arg; /* * Syntax: * tsv::append array key value ?value ...? * $object append value ?value ...? */ flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); if (ret != TCL_OK) { return TCL_ERROR; } if (objc < 1 + off) { Tcl_WrongNumArgs(interp, off, objv, "value ?value ...?"); goto cmd_err; } for (i = off; i < objc; ++i) { Tcl_AppendObjToObj(svObj->tclObj, Sv_DuplicateObj(objv[i])); } Tcl_SetObjResult(interp, Sv_DuplicateObj(svObj->tclObj)); return Sv_PutContainer(interp, svObj, SV_CHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *----------------------------------------------------------------------------- * * SvPopObjCmd -- * * This procedure is invoked to process "tsv::pop" command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvPopObjCmd( void *arg, /* Pointer to object container */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int ret; Tcl_Size off; Tcl_Obj *retObj; Array *arrayPtr = NULL; Container *svObj = (Container*)arg; /* * Syntax: * tsv::pop array key ?var? * $object pop ?var? * * Note: the object command will run into error next time ! */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); switch (ret) { case TCL_BREAK: if (objc == off) { return TCL_ERROR; } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); return TCL_OK; } case TCL_ERROR: return TCL_ERROR; } arrayPtr = svObj->arrayPtr; retObj = svObj->tclObj; svObj->tclObj = NULL; if (DeleteContainer(svObj) != TCL_OK) { if (svObj->arrayPtr->psPtr) { PsStore *psPtr = svObj->arrayPtr->psPtr; const char *err = psPtr->psError(psPtr->psHandle); Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE)); } ret = TCL_ERROR; goto cmd_exit; } if (objc == off) { Tcl_SetObjResult(interp, retObj); } else { if (Tcl_ObjSetVar2(interp, objv[off], NULL, retObj, 0) == NULL) { ret = TCL_ERROR; goto cmd_exit; } Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } cmd_exit: Tcl_DecrRefCount(retObj); UnlockArray(arrayPtr); return ret; } /* *----------------------------------------------------------------------------- * * SvMoveObjCmd -- * * This procedure is invoked to process the "tsv::move" command. * See the user documentation for details on what it does. * * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *----------------------------------------------------------------------------- */ static int SvMoveObjCmd( void *arg, /* Pointer to object container. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int ret, isNew; Tcl_Size off; const char *toKey; Tcl_HashEntry *hPtr; Container *svObj = (Container*)arg; /* * Syntax: * tsv::move array key to * $object move to */ ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); if (ret != TCL_OK) { return TCL_ERROR; } toKey = Tcl_GetString(objv[off]); hPtr = Tcl_CreateHashEntry(&svObj->arrayPtr->vars, toKey, &isNew); if (!isNew) { Tcl_AppendResult(interp, "key \"", toKey, "\" exists", (void *)NULL); goto cmd_err; } if (svObj->entryPtr) { char *key = (char *)Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr); if (svObj->arrayPtr->psPtr) { PsStore *psPtr = svObj->arrayPtr->psPtr; if (psPtr->psDelete(psPtr->psHandle, key) == -1) { const char *err = psPtr->psError(psPtr->psHandle); Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE)); return TCL_ERROR; } } Tcl_DeleteHashEntry(svObj->entryPtr); } svObj->entryPtr = hPtr; Tcl_SetHashValue(hPtr, svObj); return Sv_PutContainer(interp, svObj, SV_CHANGED); cmd_err: return Sv_PutContainer(interp, svObj, SV_ERROR); } /* *---------------------------------------------------------------------- * * SvLockObjCmd -- * * This procedure is invoked to process "tsv::lock" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int SvLockObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int ret; Tcl_Obj *scriptObj; Bucket *bucketPtr; Array *arrayPtr = NULL; /* * Syntax: * * tsv::lock array arg ?arg ...? */ if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "array arg ?arg...?"); return TCL_ERROR; } arrayPtr = LockArray(interp, Tcl_GetString(objv[1]), FLAGS_CREATEARRAY); bucketPtr = arrayPtr->bucketPtr; /* * Evaluate passed arguments as Tcl script. Note that * Tcl_EvalObjEx throws away the passed object by * doing an decrement reference count on it. This also * means we need not build object bytecode rep. */ if (objc == 3) { scriptObj = Tcl_DuplicateObj(objv[2]); } else { scriptObj = Tcl_ConcatObj(objc-2, objv + 2); } Tcl_AllowExceptions(interp); ret = Tcl_EvalObjEx(interp, scriptObj, TCL_EVAL_DIRECT); if (ret == TCL_ERROR) { char msg[32 + TCL_INTEGER_SPACE]; snprintf(msg, sizeof(msg), "\n (\"eval\" body line %d)", Tcl_GetErrorLine(interp)); Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE)); } /* * We unlock the bucket directly, w/o going to Sv_Unlock() * since it needs the array which may be unset by the script. */ UNLOCK_BUCKET(bucketPtr); return ret; } /* *----------------------------------------------------------------------------- * * SvHandlersObjCmd -- * * This procedure is invoked to process "tsv::handlers" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * None. * *----------------------------------------------------------------------------- */ static int SvHandlersObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { PsStore *tmpPtr = NULL; /* * Syntax: * * tsv::handlers */ if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } Tcl_ResetResult(interp); Tcl_MutexLock(&svMutex); for (tmpPtr = psStore; tmpPtr; tmpPtr = tmpPtr->nextPtr) { Tcl_AppendElement(interp, tmpPtr->type); } Tcl_MutexUnlock(&svMutex); return TCL_OK; } /* *----------------------------------------------------------------------------- * * Sv_RegisterStdCommands -- * * Register standard shared variable commands * * Results: * A standard Tcl result. * * Side effects: * Memory gets allocated * *----------------------------------------------------------------------------- */ static void SvRegisterStdCommands(void) { static int initialized = 0; if (initialized == 0) { Tcl_MutexLock(&initMutex); if (initialized == 0) { Sv_RegisterCommand("var", SvObjObjCmd, NULL, 1); Sv_RegisterCommand("object", SvObjObjCmd, NULL, 1); Sv_RegisterCommand("set", SvSetObjCmd, NULL, 0); Sv_RegisterCommand("unset", SvUnsetObjCmd, NULL, 0); Sv_RegisterCommand("get", SvGetObjCmd, NULL, 0); Sv_RegisterCommand("incr", SvIncrObjCmd, NULL, 0); Sv_RegisterCommand("exists", SvExistsObjCmd, NULL, 0); Sv_RegisterCommand("append", SvAppendObjCmd, NULL, 0); Sv_RegisterCommand("array", SvArrayObjCmd, NULL, 0); Sv_RegisterCommand("names", SvNamesObjCmd, NULL, 0); Sv_RegisterCommand("pop", SvPopObjCmd, NULL, 0); Sv_RegisterCommand("move", SvMoveObjCmd, NULL, 0); Sv_RegisterCommand("lock", SvLockObjCmd, NULL, 0); Sv_RegisterCommand("handlers", SvHandlersObjCmd, NULL, 0); initialized = 1; } Tcl_MutexUnlock(&initMutex); } } /* *----------------------------------------------------------------------------- * * SvInit -- * * Creates commands in current interpreter. * * Results: * NULL * * Side effects * Many new command created in current interpreter. Global data * structures used by them initialized as well. * *----------------------------------------------------------------------------- */ const char * SvInit ( Tcl_Interp *interp ) { Tcl_Size i; int b; Bucket *bucketPtr; SvCmdInfo *cmdPtr; Tcl_Obj *obj; #ifdef SV_FINALIZE /* * Create exit handler for this thread */ Tcl_CreateThreadExitHandler(SvFinalize, NULL); /* * Increment number of threads */ Tcl_MutexLock(&nofThreadsMutex); ++nofThreads; Tcl_MutexUnlock(&nofThreadsMutex); #endif /* SV_FINALIZE */ /* * Add keyed-list datatype */ TclX_KeyedListInit(interp); Sv_RegisterKeylistCommands(); /* * Register standard (nsv_* compatible) and our * own extensive set of list manipulating commands */ SvRegisterStdCommands(); Sv_RegisterListCommands(); /* * Get Tcl object types. These are used * in custom object duplicator function. */ obj = Tcl_NewStringObj("no", TCL_INDEX_NONE); Tcl_GetBooleanFromObj(NULL, obj, &b); booleanObjTypePtr = obj->typePtr; #ifdef USE_TCL_STUBS if (tclStubsPtr->tcl_GetUnicodeFromObj) #endif { Tcl_GetUnicodeFromObj(obj, &i); stringObjTypePtr = obj->typePtr; } Tcl_GetByteArrayFromObj(obj, &i); byteArrayObjTypePtr = obj->typePtr; Tcl_DecrRefCount(obj); obj = Tcl_NewDoubleObj(0.0); doubleObjTypePtr = obj->typePtr; Tcl_DecrRefCount(obj); obj = Tcl_NewIntObj(0); intObjTypePtr = obj->typePtr; Tcl_DecrRefCount(obj); obj = Tcl_NewWideIntObj(((Tcl_WideInt)1)<<35); wideIntObjTypePtr = obj->typePtr; Tcl_DecrRefCount(obj); /* * Plug-in registered commands in current interpreter */ for (cmdPtr = svCmdInfo; cmdPtr; cmdPtr = cmdPtr->nextPtr) { Tcl_CreateObjCommand2(interp, cmdPtr->cmdName, cmdPtr->objProcPtr, NULL, NULL); #ifdef NS_AOLSERVER Tcl_CreateObjCommand2(interp, cmdPtr->cmdName2, cmdPtr->objProcPtr, (void *)(size_t)cmdPtr->aolSpecial, NULL); #endif } /* * Create array of buckets and initialize each bucket */ if (buckets == NULL) { Tcl_MutexLock(&bucketsMutex); if (buckets == NULL) { buckets = (Bucket *)Tcl_Alloc(sizeof(Bucket) * NUMBUCKETS); for (i = 0; i < NUMBUCKETS; ++i) { bucketPtr = &buckets[i]; memset(bucketPtr, 0, sizeof(Bucket)); Tcl_InitHashTable(&bucketPtr->arrays, TCL_STRING_KEYS); Tcl_InitHashTable(&bucketPtr->handles, TCL_ONE_WORD_KEYS); } /* * There is no other way to get Sv_tclEmptyStringRep * pointer value w/o this trick. */ { Tcl_Obj *dummy = Tcl_NewObj(); Sv_tclEmptyStringRep = dummy->bytes; Tcl_DecrRefCount(dummy); } /* * Register persistent store handlers */ #ifdef HAVE_GDBM Sv_RegisterGdbmStore(); #endif #ifdef HAVE_LMDB Sv_RegisterLmdbStore(); #endif } Tcl_MutexUnlock(&bucketsMutex); } return NULL; } #ifdef SV_FINALIZE /* * Left for reference, but unused since multithreaded finalization is * unsolvable in the general case. Brave souls can revive this by * installing a late exit handler on Thread's behalf, bringing the * function back onto the Tcl_Finalize (but not Tcl_Exit) path. */ /* *----------------------------------------------------------------------------- * * SvFinalize -- * * Unset all arrays and reclaim all buckets. * * Results: * None. * * Side effects * Memory gets reclaimed. * *----------------------------------------------------------------------------- */ static void SvFinalize ( TCL_UNUSED(void *)) { int i; SvCmdInfo *cmdPtr; RegType *regPtr; Tcl_HashEntry *hashPtr; Tcl_HashSearch search; /* * Decrement number of threads. Proceed only if I was the last one. The * mutex is unlocked at the end of this function, so new threads that might * want to register in the meanwhile will find a clean environment when * they eventually succeed acquiring nofThreadsMutex. */ Tcl_MutexLock(&nofThreadsMutex); if (nofThreads > 1) { goto done; } /* * Reclaim memory for shared arrays */ if (buckets != NULL) { Tcl_MutexLock(&bucketsMutex); if (buckets != NULL) { for (i = 0; i < NUMBUCKETS; ++i) { Bucket *bucketPtr = &buckets[i]; hashPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search); while (hashPtr != NULL) { Array *arrayPtr = (Array*)Tcl_GetHashValue(hashPtr); UnlockArray(arrayPtr); /* unbind array before delete (avoid flush of persistent storage) */ UnbindArray(NULL, arrayPtr); /* flush, delete etc. */ DeleteArray(NULL, arrayPtr); hashPtr = Tcl_NextHashEntry(&search); } if (bucketPtr->lock) { Sp_RecursiveMutexFinalize(&bucketPtr->lock); } SvFinalizeContainers(bucketPtr); Tcl_DeleteHashTable(&bucketPtr->handles); Tcl_DeleteHashTable(&bucketPtr->arrays); } Tcl_Free(buckets), buckets = NULL; } buckets = NULL; Tcl_MutexUnlock(&bucketsMutex); } Tcl_MutexLock(&svMutex); /* * Reclaim memory for registered commands */ if (svCmdInfo != NULL) { cmdPtr = svCmdInfo; while (cmdPtr) { SvCmdInfo *tmpPtr = cmdPtr->nextPtr; Tcl_Free(cmdPtr); cmdPtr = tmpPtr; } svCmdInfo = NULL; } /* * Reclaim memory for registered object types */ if (regType != NULL) { regPtr = regType; while (regPtr) { RegType *tmpPtr = regPtr->nextPtr; Tcl_Free(regPtr); regPtr = tmpPtr; } regType = NULL; } Tcl_MutexUnlock(&svMutex); done: --nofThreads; Tcl_MutexUnlock(&nofThreadsMutex); } #endif /* SV_FINALIZE */ /* EOF $RCSfile: threadSvCmd.c,v $ */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/threadSpCmd.h0000644003604700454610000001022114726633451015272 0ustar dgp771div/* * This is the header file for the module that implements some missing * synchronization primitives from the Tcl API. * * Copyright (c) 2002 by Zoran Vasiljevic. * * See the file "license.txt" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * --------------------------------------------------------------------------- */ #ifndef _SP_H_ #define _SP_H_ #include "tclThreadInt.h" /* * The following structure defines a locking bucket. A locking * bucket is associated with a mutex and protects access to * objects stored in bucket hash table. */ typedef struct SpBucket { Tcl_Mutex lock; /* For locking the bucket */ Tcl_Condition cond; /* For waiting on threads to release items */ Tcl_HashTable handles; /* Hash table of given-out handles in bucket */ } SpBucket; #define NUMSPBUCKETS 32 /* * All types of mutexes share this common part. */ typedef struct Sp_AnyMutex_ { int lockcount; /* If !=0 mutex is locked */ int numlocks; /* Number of times the mutex got locked */ Tcl_Mutex lock; /* Regular mutex */ Tcl_ThreadId owner; /* Current lock owner thread (-1 = any) */ } Sp_AnyMutex; /* * Implementation of the exclusive mutex. */ typedef struct Sp_ExclusiveMutex_ { int lockcount; /* Flag: 1-locked, 0-not locked */ int numlocks; /* Number of times the mutex got locked */ Tcl_Mutex lock; /* Regular mutex */ Tcl_ThreadId owner; /* Current lock owner thread */ /* --- */ Tcl_Mutex mutex; /* Mutex being locked */ } Sp_ExclusiveMutex_; typedef Sp_ExclusiveMutex_* Sp_ExclusiveMutex; /* * Implementation of the recursive mutex. */ typedef struct Sp_RecursiveMutex_ { int lockcount; /* # of times this mutex is locked */ int numlocks; /* Number of time the mutex got locked */ Tcl_Mutex lock; /* Regular mutex */ Tcl_ThreadId owner; /* Current lock owner thread */ /* --- */ Tcl_Condition cond; /* Wait to be allowed to lock the mutex */ } Sp_RecursiveMutex_; typedef Sp_RecursiveMutex_* Sp_RecursiveMutex; /* * Implementation of the read/writer mutex. */ typedef struct Sp_ReadWriteMutex_ { int lockcount; /* >0: # of readers, -1: sole writer */ int numlocks; /* Number of time the mutex got locked */ Tcl_Mutex lock; /* Regular mutex */ Tcl_ThreadId owner; /* Current lock owner thread */ /* --- */ unsigned int numrd; /* # of readers waiting for lock */ unsigned int numwr; /* # of writers waiting for lock */ Tcl_Condition rcond; /* Reader lockers wait here */ Tcl_Condition wcond; /* Writer lockers wait here */ } Sp_ReadWriteMutex_; typedef Sp_ReadWriteMutex_* Sp_ReadWriteMutex; /* * API for exclusive mutexes. */ MODULE_SCOPE int Sp_ExclusiveMutexLock(Sp_ExclusiveMutex *mutexPtr); MODULE_SCOPE int Sp_ExclusiveMutexIsLocked(Sp_ExclusiveMutex *mutexPtr); MODULE_SCOPE int Sp_ExclusiveMutexUnlock(Sp_ExclusiveMutex *mutexPtr); MODULE_SCOPE void Sp_ExclusiveMutexFinalize(Sp_ExclusiveMutex *mutexPtr); /* * API for recursive mutexes. */ MODULE_SCOPE int Sp_RecursiveMutexLock(Sp_RecursiveMutex *mutexPtr); MODULE_SCOPE int Sp_RecursiveMutexIsLocked(Sp_RecursiveMutex *mutexPtr); MODULE_SCOPE int Sp_RecursiveMutexUnlock(Sp_RecursiveMutex *mutexPtr); MODULE_SCOPE void Sp_RecursiveMutexFinalize(Sp_RecursiveMutex *mutexPtr); /* * API for reader/writer mutexes. */ MODULE_SCOPE int Sp_ReadWriteMutexRLock(Sp_ReadWriteMutex *mutexPtr); MODULE_SCOPE int Sp_ReadWriteMutexWLock(Sp_ReadWriteMutex *mutexPtr); MODULE_SCOPE int Sp_ReadWriteMutexIsLocked(Sp_ReadWriteMutex *mutexPtr); MODULE_SCOPE int Sp_ReadWriteMutexUnlock(Sp_ReadWriteMutex *mutexPtr); MODULE_SCOPE void Sp_ReadWriteMutexFinalize(Sp_ReadWriteMutex *mutexPtr); #endif /* _SP_H_ */ /* EOF $RCSfile: threadSpCmd.h,v $ */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/threadSpCmd.c0000644003604700454610000013317514731033512015267 0ustar dgp771div/* * threadSpCmd.c -- * * This file implements commands for script-level access to thread * synchronization primitives. Currently, the exclusive mutex, the * recursive mutex. the reader/writer mutex and condition variable * objects are exposed to the script programmer. * * Additionaly, a locked eval is also implemented. This is a practical * convenience function which relieves the programmer from the need * to take care about unlocking some mutex after evaluating a protected * part of code. The locked eval is recursive-savvy since it used the * recursive mutex for internal locking. * * The Tcl interface to the locking and synchronization primitives * attempts to catch some very common problems in thread programming * like attempting to lock an exclusive mutex twice from the same * thread (deadlock), waiting on the condition variable without * locking the mutex, destroying primitives while being used, etc... * This all comes with some additional internal locking costs but * the benefits outweight the costs, especially considering overall * performance (or lack of it) of an interpreted laguage like Tcl is. * * Copyright (c) 2002 by Zoran Vasiljevic. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * ---------------------------------------------------------------------------- */ #include "tclThreadInt.h" #include "threadSpCmd.h" /* * Types of synchronization variables we support. */ #define EMUTEXID 'm' /* First letter of the exclusive mutex name */ #define RMUTEXID 'r' /* First letter of the recursive mutex name */ #define WMUTEXID 'w' /* First letter of the read/write mutex name */ #define CONDVID 'c' /* First letter of the condition variable name */ #define SP_MUTEX 1 /* Any kind of mutex */ #define SP_CONDV 2 /* The condition variable sync type */ /* * Structure representing one sync primitive (mutex, condition variable). * We use buckets to manage Tcl names of sync primitives. Each bucket * is associated with a mutex. Each time we process the Tcl name of an * sync primitive, we compute it's (trivial) hash and use this hash to * address one of pre-allocated buckets. * The bucket internally utilzes a hash-table to store item pointers. * Item pointers are identified by a simple xid1, xid2... counting * handle. This format is chosen to simplify distribution of handles * across buckets (natural distribution vs. hash-one as in shared vars). */ typedef struct _SpItem { int refcnt; /* Number of threads operating on the item */ SpBucket *bucket; /* Bucket where this item is stored */ Tcl_HashEntry *hentry; /* Hash table entry where this item is stored */ } SpItem; /* * Structure representing a mutex. */ typedef struct _SpMutex { int refcnt; /* Number of threads operating on the mutex */ SpBucket *bucket; /* Bucket where mutex is stored */ Tcl_HashEntry *hentry; /* Hash table entry where mutex is stored */ /* --- */ char type; /* Type of the mutex */ Sp_AnyMutex *lock; /* Exclusive, recursive or read/write mutex */ } SpMutex; /* * Structure representing a condition variable. */ typedef struct _SpCondv { int refcnt; /* Number of threads operating on the variable */ SpBucket *bucket; /* Bucket where this variable is stored */ Tcl_HashEntry *hentry; /* Hash table entry where variable is stored */ /* --- */ SpMutex *mutex; /* Set when waiting on the variable */ Tcl_Condition cond; /* The condition variable itself */ } SpCondv; /* * This global data is used to map opaque Tcl-level names * to pointers of their corresponding synchronization objects. */ static int initOnce; /* Flag for initializing tables below */ static Tcl_Mutex initMutex; /* Controls initialization of primitives */ static SpBucket muxBuckets[NUMSPBUCKETS]; /* Maps mutex names/handles */ static SpBucket varBuckets[NUMSPBUCKETS]; /* Maps condition variable * names/handles */ /* * Functions implementing Tcl commands */ static Tcl_ObjCmdProc2 ThreadMutexObjCmd; static Tcl_ObjCmdProc2 ThreadRWMutexObjCmd; static Tcl_ObjCmdProc2 ThreadCondObjCmd; static Tcl_ObjCmdProc2 ThreadEvalObjCmd; /* * Forward declaration of functions used only within this file */ static int SpMutexLock (SpMutex *); static int SpMutexUnlock (SpMutex *); static int SpMutexFinalize (SpMutex *); static int SpCondvWait (SpCondv *, SpMutex *, int); static void SpCondvNotify (SpCondv *); static int SpCondvFinalize (SpCondv *); static void AddAnyItem (int, const char *, size_t, SpItem *); static SpItem* GetAnyItem (int, const char *, size_t); static void PutAnyItem (SpItem *); static SpItem * RemoveAnyItem (int, const char*, size_t); static int RemoveMutex (const char *, size_t); static int RemoveCondv (const char *, size_t); static Tcl_Obj* GetName (int, void *); static SpBucket* GetBucket (int, const char *, size_t); static int AnyMutexIsLocked (Sp_AnyMutex *mPtr, Tcl_ThreadId); /* * Function-like macros for some frequently used calls */ #define AddMutex(a,b,c) AddAnyItem(SP_MUTEX, (a), (b), (SpItem*)(c)) #define GetMutex(a,b) (SpMutex*)GetAnyItem(SP_MUTEX, (a), (b)) #define PutMutex(a) PutAnyItem((SpItem*)(a)) #define AddCondv(a,b,c) AddAnyItem(SP_CONDV, (a), (b), (SpItem*)(c)) #define GetCondv(a,b) (SpCondv*)GetAnyItem(SP_CONDV, (a), (b)) #define PutCondv(a) PutAnyItem((SpItem*)(a)) #define IsExclusive(a) ((a)->type == EMUTEXID) #define IsRecursive(a) ((a)->type == RMUTEXID) #define IsReadWrite(a) ((a)->type == WMUTEXID) /* * This macro produces a hash-value for table-lookups given a handle * and its length. It is implemented as macro just for speed. * It is actually a trivial thing because the handles are simple * counting values with a small three-letter prefix. */ #define GetHash(a,b) (atoi((a)+((b) < 4 ? 0 : 3)) % NUMSPBUCKETS) /* *---------------------------------------------------------------------- * * ThreadMutexObjCmd -- * * This procedure is invoked to process "thread::mutex" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadMutexObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { int ret; Tcl_Size nameLen; const char *mutexName; char type; SpMutex *mutexPtr; static const char *const cmdOpts[] = { "create", "destroy", "lock", "unlock", NULL }; enum options { m_CREATE, m_DESTROY, m_LOCK, m_UNLOCK } opt; /* * Syntax: * * thread::mutex create ?-recursive? * thread::mutex destroy * thread::mutex lock * thread::mutex unlock */ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); return TCL_ERROR; } ret = Tcl_GetIndexFromObjStruct(interp, objv[1], cmdOpts, sizeof(char *), "option", 0, &opt); if (ret != TCL_OK) { return TCL_ERROR; } /* * Cover the "create" option first. It needs no existing handle. */ if (opt == (int)m_CREATE) { Tcl_Obj *nameObj; const char *arg; /* * Parse out which type of mutex to create */ if (objc == 2) { type = EMUTEXID; } else if (objc > 3) { Tcl_WrongNumArgs(interp, 2, objv, "?-recursive?"); return TCL_ERROR; } else { arg = Tcl_GetString(objv[2]); if (OPT_CMP(arg, "-recursive")) { type = RMUTEXID; } else { Tcl_WrongNumArgs(interp, 2, objv, "?-recursive?"); return TCL_ERROR; } } /* * Create the requested mutex */ mutexPtr = (SpMutex *)Tcl_Alloc(sizeof(SpMutex)); mutexPtr->type = type; mutexPtr->bucket = NULL; mutexPtr->hentry = NULL; mutexPtr->lock = NULL; /* Will be auto-initialized */ /* * Generate Tcl name for this mutex */ nameObj = GetName(mutexPtr->type, (void*)mutexPtr); mutexName = Tcl_GetStringFromObj(nameObj, &nameLen); AddMutex(mutexName, nameLen, mutexPtr); Tcl_SetObjResult(interp, nameObj); return TCL_OK; } /* * All other options require a valid name. */ if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "mutexHandle"); return TCL_ERROR; } mutexName = Tcl_GetStringFromObj(objv[2], &nameLen); /* * Try mutex destroy */ if (opt == m_DESTROY) { ret = RemoveMutex(mutexName, nameLen); if (ret <= 0) { if (ret == -1) { notfound: Tcl_AppendResult(interp, "no such mutex \"", mutexName, "\"", (void *)NULL); return TCL_ERROR; } else { Tcl_AppendResult(interp, "mutex is in use", (void *)NULL); return TCL_ERROR; } } return TCL_OK; } /* * Try all other options */ mutexPtr = GetMutex(mutexName, nameLen); if (mutexPtr == NULL) { goto notfound; } if (!IsExclusive(mutexPtr) && !IsRecursive(mutexPtr)) { PutMutex(mutexPtr); Tcl_AppendResult(interp, "wrong mutex type, must be either" " exclusive or recursive", (void *)NULL); return TCL_ERROR; } switch (opt) { case m_LOCK: if (!SpMutexLock(mutexPtr)) { PutMutex(mutexPtr); Tcl_AppendResult(interp, "locking the same exclusive mutex " "twice from the same thread", (void *)NULL); return TCL_ERROR; } break; case m_UNLOCK: if (!SpMutexUnlock(mutexPtr)) { PutMutex(mutexPtr); Tcl_AppendResult(interp, "mutex is not locked", (void *)NULL); return TCL_ERROR; } break; default: break; } PutMutex(mutexPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * ThreadRwMutexObjCmd -- * * This procedure is invoked to process "thread::rwmutex" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadRWMutexObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { int ret; Tcl_Size nameLen; const char *mutexName; SpMutex *mutexPtr; Sp_ReadWriteMutex *rwPtr; Sp_AnyMutex **lockPtr; static const char *const cmdOpts[] = { "create", "destroy", "rlock", "wlock", "unlock", NULL }; enum options { w_CREATE, w_DESTROY, w_RLOCK, w_WLOCK, w_UNLOCK } opt; /* * Syntax: * * thread::rwmutex create * thread::rwmutex destroy * thread::rwmutex rlock * thread::rwmutex wlock * thread::rwmutex unlock */ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); return TCL_ERROR; } ret = Tcl_GetIndexFromObjStruct(interp, objv[1], cmdOpts, sizeof(char *), "option", 0, &opt); if (ret != TCL_OK) { return TCL_ERROR; } /* * Cover the "create" option first, since it needs no existing name. */ if (opt == w_CREATE) { Tcl_Obj *nameObj; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "create"); return TCL_ERROR; } mutexPtr = (SpMutex *)Tcl_Alloc(sizeof(SpMutex)); mutexPtr->type = WMUTEXID; mutexPtr->refcnt = 0; mutexPtr->bucket = NULL; mutexPtr->hentry = NULL; mutexPtr->lock = NULL; /* Will be auto-initialized */ nameObj = GetName(mutexPtr->type, (void*)mutexPtr); mutexName = Tcl_GetStringFromObj(nameObj, &nameLen); AddMutex(mutexName, nameLen, mutexPtr); Tcl_SetObjResult(interp, nameObj); return TCL_OK; } /* * All other options require a valid name. */ if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "mutexHandle"); return TCL_ERROR; } mutexName = Tcl_GetStringFromObj(objv[2], &nameLen); /* * Try mutex destroy */ if (opt == w_DESTROY) { ret = RemoveMutex(mutexName, nameLen); if (ret <= 0) { if (ret == -1) { notfound: Tcl_AppendResult(interp, "no such mutex \"", mutexName, "\"", (void *)NULL); return TCL_ERROR; } else { Tcl_AppendResult(interp, "mutex is in use", (void *)NULL); return TCL_ERROR; } } return TCL_OK; } /* * Try all other options */ mutexPtr = GetMutex(mutexName, nameLen); if (mutexPtr == NULL) { goto notfound; } if (!IsReadWrite(mutexPtr)) { PutMutex(mutexPtr); Tcl_AppendResult(interp, "wrong mutex type, must be readwrite", (void *)NULL); return TCL_ERROR; } lockPtr = &mutexPtr->lock; rwPtr = (Sp_ReadWriteMutex*) lockPtr; switch (opt) { case w_RLOCK: if (!Sp_ReadWriteMutexRLock(rwPtr)) { PutMutex(mutexPtr); Tcl_AppendResult(interp, "read-locking already write-locked mutex ", "from the same thread", (void *)NULL); return TCL_ERROR; } break; case w_WLOCK: if (!Sp_ReadWriteMutexWLock(rwPtr)) { PutMutex(mutexPtr); Tcl_AppendResult(interp, "write-locking the same read-write " "mutex twice from the same thread", (void *)NULL); return TCL_ERROR; } break; case w_UNLOCK: if (!Sp_ReadWriteMutexUnlock(rwPtr)) { PutMutex(mutexPtr); Tcl_AppendResult(interp, "mutex is not locked", (void *)NULL); return TCL_ERROR; } break; default: break; } PutMutex(mutexPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * ThreadCondObjCmd -- * * This procedure is invoked to process "thread::cond" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadCondObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { int ret, timeMsec = 0; Tcl_Size nameLen; const char *condvName, *mutexName; SpMutex *mutexPtr; SpCondv *condvPtr; static const char *const cmdOpts[] = { "create", "destroy", "notify", "wait", NULL }; enum options { c_CREATE, c_DESTROY, c_NOTIFY, c_WAIT } opt; /* * Syntax: * * thread::cond create * thread::cond destroy * thread::cond notify * thread::cond wait ?timeout? */ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); return TCL_ERROR; } ret = Tcl_GetIndexFromObjStruct(interp, objv[1], cmdOpts, sizeof(char *), "option", 0, &opt); if (ret != TCL_OK) { return TCL_ERROR; } /* * Cover the "create" option since it needs no existing name. */ if (opt == c_CREATE) { Tcl_Obj *nameObj; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "create"); return TCL_ERROR; } condvPtr = (SpCondv *)Tcl_Alloc(sizeof(SpCondv)); condvPtr->refcnt = 0; condvPtr->bucket = NULL; condvPtr->hentry = NULL; condvPtr->mutex = NULL; condvPtr->cond = NULL; /* Will be auto-initialized */ nameObj = GetName(CONDVID, (void*)condvPtr); condvName = Tcl_GetString(nameObj); AddCondv(condvName, nameObj->length, condvPtr); Tcl_SetObjResult(interp, nameObj); return TCL_OK; } /* * All others require at least a valid handle. */ if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "condHandle ?args?"); return TCL_ERROR; } condvName = Tcl_GetStringFromObj(objv[2], &nameLen); /* * Try variable destroy. */ if (opt == c_DESTROY) { ret = RemoveCondv(condvName, nameLen); if (ret <= 0) { if (ret == -1) { notfound: Tcl_AppendResult(interp, "no such condition variable \"", condvName, "\"", (void *)NULL); return TCL_ERROR; } else { Tcl_AppendResult(interp, "condition variable is in use", (void *)NULL); return TCL_ERROR; } } return TCL_OK; } /* * Try all other options */ condvPtr = GetCondv(condvName, nameLen); if (condvPtr == NULL) { goto notfound; } switch (opt) { case c_WAIT: /* * May improve the Tcl_ConditionWait() to report timeouts so we can * inform script programmer about this interesting fact. I think * there is still a place for something like Tcl_ConditionWaitEx() * or similar in the core. */ if (objc < 4 || objc > 5) { PutCondv(condvPtr); Tcl_WrongNumArgs(interp, 2, objv, "condHandle mutexHandle ?timeout?"); return TCL_ERROR; } if (objc == 5) { if (Tcl_GetIntFromObj(interp, objv[4], &timeMsec) != TCL_OK) { PutCondv(condvPtr); return TCL_ERROR; } } mutexName = Tcl_GetString(objv[3]); mutexPtr = GetMutex(mutexName, objv[3]->length); if (mutexPtr == NULL) { PutCondv(condvPtr); Tcl_AppendResult(interp, "no such mutex \"",mutexName,"\"", (void *)NULL); return TCL_ERROR; } if (!IsExclusive(mutexPtr) || SpCondvWait(condvPtr, mutexPtr, timeMsec) == 0) { PutCondv(condvPtr); PutMutex(mutexPtr); Tcl_AppendResult(interp, "mutex not locked or wrong type", (void *)NULL); return TCL_ERROR; } PutMutex(mutexPtr); break; case c_NOTIFY: SpCondvNotify(condvPtr); break; default: break; } PutCondv(condvPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * ThreadEvalObjCmd -- * * This procedure is invoked to process "thread::eval" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadEvalObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { int ret, internal; Tcl_Size optx; const char *mutexName; Tcl_Obj *scriptObj; SpMutex *mutexPtr = NULL; static Sp_RecursiveMutex evalMutex; /* * Syntax: * * thread::eval ?-lock ? arg ?arg ...? */ if (objc < 2) { syntax: Tcl_WrongNumArgs(interp, 1, objv, "?-lock ? arg ?arg...?"); return TCL_ERROR; } /* * Find out whether to use the internal (recursive) mutex * or external mutex given on the command line, and lock * the corresponding mutex immediately. * * We are using recursive internal mutex so we can easily * support the recursion w/o danger of deadlocking. If * however, user gives us an exclusive mutex, we will * throw error on attempt to recursively call us. */ if (OPT_CMP(Tcl_GetString(objv[1]), "-lock") == 0) { internal = 1; optx = 1; Sp_RecursiveMutexLock(&evalMutex); } else { internal = 0; optx = 3; if (objc < 1 + optx) { goto syntax; } mutexName = Tcl_GetString(objv[2]); mutexPtr = GetMutex(mutexName, objv[2]->length); if (mutexPtr == NULL) { Tcl_AppendResult(interp, "no such mutex \"",mutexName,"\"", (void *)NULL); return TCL_ERROR; } if (IsReadWrite(mutexPtr)) { PutMutex(mutexPtr); Tcl_AppendResult(interp, "wrong mutex type, must be exclusive " "or recursive", (void *)NULL); return TCL_ERROR; } if (!SpMutexLock(mutexPtr)) { PutMutex(mutexPtr); Tcl_AppendResult(interp, "locking the same exclusive mutex " "twice from the same thread", (void *)NULL); return TCL_ERROR; } } objc -= optx; /* * Evaluate passed arguments as Tcl script. Note that * Tcl_EvalObjEx throws away the passed object by * doing an decrement reference count on it. This also * means we need not build object bytecode rep. */ if (objc == 1) { scriptObj = Tcl_DuplicateObj(objv[optx]); } else { scriptObj = Tcl_ConcatObj(objc, objv + optx); } Tcl_IncrRefCount(scriptObj); ret = Tcl_EvalObjEx(interp, scriptObj, TCL_EVAL_DIRECT); Tcl_DecrRefCount(scriptObj); if (ret == TCL_ERROR) { char msg[32 + TCL_INTEGER_SPACE]; snprintf(msg, sizeof(msg), "\n (\"eval\" body line %d)", Tcl_GetErrorLine(interp)); Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE)); } /* * Unlock the mutex. */ if (internal) { Sp_RecursiveMutexUnlock(&evalMutex); } else { SpMutexUnlock(mutexPtr); PutMutex(mutexPtr); } return ret; } /* *---------------------------------------------------------------------- * * GetName -- * * Construct a Tcl name for the given sync primitive. * The name is in the simple counted form: XidN * where "X" designates the type of the primitive * and "N" is a increasing integer. * * Results: * Tcl string object with the constructed name. * * Side effects: * None. * *---------------------------------------------------------------------- */ static Tcl_Obj* GetName( int type, TCL_UNUSED(void *)) { char name[32]; size_t id; static size_t idcounter; Tcl_MutexLock(&initMutex); id = idcounter++; Tcl_MutexUnlock(&initMutex); snprintf(name, sizeof(name), "%cid%" TCL_Z_MODIFIER "u", type, id); return Tcl_NewStringObj(name, TCL_INDEX_NONE); } /* *---------------------------------------------------------------------- * * GetBucket -- * * Returns the bucket for the given name. * * Results: * Pointer to the bucket. * * Side effects: * None. * *---------------------------------------------------------------------- */ static SpBucket* GetBucket(int type, const char *name, size_t len) { switch (type) { case SP_MUTEX: return &muxBuckets[GetHash(name, len)]; case SP_CONDV: return &varBuckets[GetHash(name, len)]; } return NULL; /* Never reached */ } /* *---------------------------------------------------------------------- * * GetAnyItem -- * * Retrieves the item structure from it's corresponding bucket. * * Results: * Item pointer or NULL * * Side effects: * Increment the item's ref count preventing it's deletion. * *---------------------------------------------------------------------- */ static SpItem* GetAnyItem(int type, const char *name, size_t len) { SpItem *itemPtr = NULL; SpBucket *bucketPtr = GetBucket(type, name, len); Tcl_HashEntry *hashEntryPtr = NULL; Tcl_MutexLock(&bucketPtr->lock); hashEntryPtr = Tcl_FindHashEntry(&bucketPtr->handles, name); if (hashEntryPtr != NULL) { itemPtr = (SpItem*)Tcl_GetHashValue(hashEntryPtr); itemPtr->refcnt++; } Tcl_MutexUnlock(&bucketPtr->lock); return itemPtr; } /* *---------------------------------------------------------------------- * * PutAnyItem -- * * Current thread detaches from the item. * * Results: * None. * * Side effects: * Decrement item's ref count allowing for it's deletion * and signalize any threads waiting to delete the item. * *---------------------------------------------------------------------- */ static void PutAnyItem(SpItem *itemPtr) { Tcl_MutexLock(&itemPtr->bucket->lock); itemPtr->refcnt--; Tcl_ConditionNotify(&itemPtr->bucket->cond); Tcl_MutexUnlock(&itemPtr->bucket->lock); } /* *---------------------------------------------------------------------- * * AddAnyItem -- * * Puts any item in the corresponding bucket. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void AddAnyItem(int type, const char *handle, size_t len, SpItem *itemPtr) { int isNew; SpBucket *bucketPtr = GetBucket(type, handle, len); Tcl_HashEntry *hashEntryPtr; Tcl_MutexLock(&bucketPtr->lock); hashEntryPtr = Tcl_CreateHashEntry(&bucketPtr->handles, handle, &isNew); Tcl_SetHashValue(hashEntryPtr, itemPtr); itemPtr->refcnt = 0; itemPtr->bucket = bucketPtr; itemPtr->hentry = hashEntryPtr; Tcl_MutexUnlock(&bucketPtr->lock); } /* *---------------------------------------------------------------------- * * RemoveAnyItem -- * * Removes the item from it's bucket. * * Results: * Item's pointer or NULL if none found. * * Side effects: * None. * *---------------------------------------------------------------------- */ static SpItem * RemoveAnyItem(int type, const char *name, size_t len) { SpItem *itemPtr = NULL; SpBucket *bucketPtr = GetBucket(type, name, len); Tcl_HashEntry *hashEntryPtr = NULL; Tcl_MutexLock(&bucketPtr->lock); hashEntryPtr = Tcl_FindHashEntry(&bucketPtr->handles, name); if (hashEntryPtr == NULL) { Tcl_MutexUnlock(&bucketPtr->lock); return NULL; } itemPtr = (SpItem*)Tcl_GetHashValue(hashEntryPtr); Tcl_DeleteHashEntry(hashEntryPtr); while (itemPtr->refcnt > 0) { Tcl_ConditionWait(&bucketPtr->cond, &bucketPtr->lock, NULL); } Tcl_MutexUnlock(&bucketPtr->lock); return itemPtr; } /* *---------------------------------------------------------------------- * * RemoveMutex -- * * Removes the mutex from it's bucket and finalizes it. * * Results: * 1 - mutex is finalized and removed * 0 - mutex is not finalized + -1 - mutex is not found * * Side effects: * None. * *---------------------------------------------------------------------- */ static int RemoveMutex(const char *name, size_t len) { SpMutex *mutexPtr = GetMutex(name, len); if (mutexPtr == NULL) { return -1; } if (!SpMutexFinalize(mutexPtr)) { PutMutex(mutexPtr); return 0; } PutMutex(mutexPtr); RemoveAnyItem(SP_MUTEX, name, len); Tcl_Free(mutexPtr); return 1; } /* *---------------------------------------------------------------------- * * RemoveCondv -- * * Removes the cond variable from it's bucket and finalizes it. * * Results: * 1 - variable is finalized and removed * 0 - variable is not finalized + -1 - variable is not found * * Side effects: * None. * *---------------------------------------------------------------------- */ static int RemoveCondv(const char *name, size_t len) { SpCondv *condvPtr = GetCondv(name, len); if (condvPtr == NULL) { return -1; } if (!SpCondvFinalize(condvPtr)) { PutCondv(condvPtr); return 0; } PutCondv(condvPtr); RemoveAnyItem(SP_CONDV, name, len); Tcl_Free(condvPtr); return 1; } /* *---------------------------------------------------------------------- * * SpInit -- * * Create commands in current interpreter. * * Results: * NULL * * Side effects: * Initializes shared hash table for storing sync primitive * handles and pointers. * *---------------------------------------------------------------------- */ const char * SpInit ( Tcl_Interp *interp /* Interp where to create cmds */ ) { SpBucket *bucketPtr; if (!initOnce) { Tcl_MutexLock(&initMutex); if (!initOnce) { int ii; for (ii = 0; ii < NUMSPBUCKETS; ii++) { bucketPtr = &muxBuckets[ii]; memset(bucketPtr, 0, sizeof(SpBucket)); Tcl_InitHashTable(&bucketPtr->handles, TCL_STRING_KEYS); } for (ii = 0; ii < NUMSPBUCKETS; ii++) { bucketPtr = &varBuckets[ii]; memset(bucketPtr, 0, sizeof(SpBucket)); Tcl_InitHashTable(&bucketPtr->handles, TCL_STRING_KEYS); } initOnce = 1; } Tcl_MutexUnlock(&initMutex); } TCL_CMD(interp, THREAD_CMD_PREFIX"::mutex", ThreadMutexObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"::rwmutex", ThreadRWMutexObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"::cond", ThreadCondObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"::eval", ThreadEvalObjCmd); return NULL; } /* *---------------------------------------------------------------------- * * SpMutexLock -- * * Locks the typed mutex. * * Results: * 1 - mutex is locked * 0 - mutex is not locked (pending deadlock?) * * Side effects: * None. * *---------------------------------------------------------------------- */ static int SpMutexLock(SpMutex *mutexPtr) { Sp_AnyMutex **lockPtr = &mutexPtr->lock; switch (mutexPtr->type) { case EMUTEXID: return Sp_ExclusiveMutexLock((Sp_ExclusiveMutex*)lockPtr); break; case RMUTEXID: return Sp_RecursiveMutexLock((Sp_RecursiveMutex*)lockPtr); break; } return 0; } /* *---------------------------------------------------------------------- * * SpMutexUnlock -- * * Unlocks the typed mutex. * * Results: * 1 - mutex is unlocked * 0 - mutex was not locked * * Side effects: * None. * *---------------------------------------------------------------------- */ static int SpMutexUnlock(SpMutex *mutexPtr) { Sp_AnyMutex **lockPtr = &mutexPtr->lock; switch (mutexPtr->type) { case EMUTEXID: return Sp_ExclusiveMutexUnlock((Sp_ExclusiveMutex*)lockPtr); break; case RMUTEXID: return Sp_RecursiveMutexUnlock((Sp_RecursiveMutex*)lockPtr); break; } return 0; } /* *---------------------------------------------------------------------- * * SpMutexFinalize -- * * Finalizes the typed mutex. This should never be called without * some external mutex protection. * * Results: * 1 - mutex is finalized * 0 - mutex is still in use * * Side effects: * None. * *---------------------------------------------------------------------- */ static int SpMutexFinalize(SpMutex *mutexPtr) { Sp_AnyMutex **lockPtr = &mutexPtr->lock; if (AnyMutexIsLocked((Sp_AnyMutex*)mutexPtr->lock, NULL)) { return 0; } /* * At this point, the mutex could be locked again, hence it * is important never to call this function unprotected. */ switch (mutexPtr->type) { case EMUTEXID: Sp_ExclusiveMutexFinalize((Sp_ExclusiveMutex*)lockPtr); break; case RMUTEXID: Sp_RecursiveMutexFinalize((Sp_RecursiveMutex*)lockPtr); break; case WMUTEXID: Sp_ReadWriteMutexFinalize((Sp_ReadWriteMutex*)lockPtr); break; default: break; } return 1; } /* *---------------------------------------------------------------------- * * SpCondvWait -- * * Waits on the condition variable. * * Results: * 1 - wait ok * 0 - not waited as mutex is not locked in the same thread * * Side effects: * None. * *---------------------------------------------------------------------- */ static int SpCondvWait(SpCondv *condvPtr, SpMutex *mutexPtr, int msec) { Sp_AnyMutex **lock = &mutexPtr->lock; Sp_ExclusiveMutex_ *emPtr = *(Sp_ExclusiveMutex_**)lock; Tcl_Time waitTime, *wt = NULL; Tcl_ThreadId threadId = Tcl_GetCurrentThread(); if (msec > 0) { wt = &waitTime; wt->sec = (msec/1000); wt->usec = (msec%1000) * 1000; } if (!AnyMutexIsLocked((Sp_AnyMutex*)mutexPtr->lock, threadId)) { return 0; /* Mutex not locked by the current thread */ } /* * It is safe to operate on mutex struct because caller * is holding the emPtr->mutex locked before we enter * the Tcl_ConditionWait and after we return out of it. */ condvPtr->mutex = mutexPtr; emPtr->owner = NULL; emPtr->lockcount = 0; Tcl_ConditionWait(&condvPtr->cond, &emPtr->mutex, wt); emPtr->owner = threadId; emPtr->lockcount = 1; condvPtr->mutex = NULL; return 1; } /* *---------------------------------------------------------------------- * * SpCondvNotify -- * * Signalizes the condition variable. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void SpCondvNotify(SpCondv *condvPtr) { if (condvPtr->cond) { Tcl_ConditionNotify(&condvPtr->cond); } } /* *---------------------------------------------------------------------- * * SpCondvFinalize -- * * Finalizes the condition variable. * * Results: * 1 - variable is finalized * 0 - variable is in use * * Side effects: * None. * *---------------------------------------------------------------------- */ static int SpCondvFinalize(SpCondv *condvPtr) { if (condvPtr->mutex != NULL) { return 0; /* Somebody is waiting on the variable */ } if (condvPtr->cond) { Tcl_ConditionFinalize(&condvPtr->cond); } return 1; } /* *---------------------------------------------------------------------- * * Sp_ExclusiveMutexLock -- * * Locks the exclusive mutex. * * Results: * 1 - mutex is locked * 0 - mutex is not locked; same thread tries to locks twice * * Side effects: * None. * *---------------------------------------------------------------------- */ int Sp_ExclusiveMutexLock(Sp_ExclusiveMutex *muxPtr) { Sp_ExclusiveMutex_ *emPtr; Tcl_ThreadId thisThread = Tcl_GetCurrentThread(); /* * Allocate the mutex structure on first access */ if (*muxPtr == NULL) { Tcl_MutexLock(&initMutex); if (*muxPtr == NULL) { *muxPtr = (Sp_ExclusiveMutex_ *)Tcl_Alloc(sizeof(Sp_ExclusiveMutex_)); memset(*muxPtr, 0, sizeof(Sp_ExclusiveMutex_)); } Tcl_MutexUnlock(&initMutex); } /* * Try locking if not currently locked by anybody. */ emPtr = *(Sp_ExclusiveMutex_**)muxPtr; Tcl_MutexLock(&emPtr->lock); if (emPtr->lockcount && emPtr->owner == thisThread) { Tcl_MutexUnlock(&emPtr->lock); return 0; /* Already locked by the same thread */ } Tcl_MutexUnlock(&emPtr->lock); /* * Many threads can come to this point. * Only one will succeed locking the * mutex. Others will block... */ Tcl_MutexLock(&emPtr->mutex); Tcl_MutexLock(&emPtr->lock); emPtr->owner = thisThread; emPtr->lockcount = 1; Tcl_MutexUnlock(&emPtr->lock); return 1; } /* *---------------------------------------------------------------------- * * Sp_ExclusiveMutexIsLocked -- * * Checks wether the mutex is locked or not. * * Results: * 1 - mutex is locked * 0 - mutex is not locked * * Side effects: * None. * *---------------------------------------------------------------------- */ int Sp_ExclusiveMutexIsLocked(Sp_ExclusiveMutex *muxPtr) { return AnyMutexIsLocked((Sp_AnyMutex*)*muxPtr, NULL); } /* *---------------------------------------------------------------------- * * Sp_ExclusiveMutexUnlock -- * * Unlock the exclusive mutex. * * Results: * 1 - mutex is unlocked ? 0 - mutex was never locked * * Side effects: * None. * *---------------------------------------------------------------------- */ int Sp_ExclusiveMutexUnlock(Sp_ExclusiveMutex *muxPtr) { Sp_ExclusiveMutex_ *emPtr; if (*muxPtr == (Sp_ExclusiveMutex_*)0) { return 0; /* Never locked before */ } emPtr = *(Sp_ExclusiveMutex_**)muxPtr; Tcl_MutexLock(&emPtr->lock); if (emPtr->lockcount == 0) { Tcl_MutexUnlock(&emPtr->lock); return 0; /* Not locked */ } emPtr->owner = NULL; emPtr->lockcount = 0; Tcl_MutexUnlock(&emPtr->lock); /* * Only one thread should be able * to come to this point and unlock... */ Tcl_MutexUnlock(&emPtr->mutex); return 1; } /* *---------------------------------------------------------------------- * * Sp_ExclusiveMutexFinalize -- * * Finalize the exclusive mutex. It is not safe for two or * more threads to finalize the mutex at the same time. * * Results: * None. * * Side effects: * Mutex is destroyed. * *---------------------------------------------------------------------- */ void Sp_ExclusiveMutexFinalize(Sp_ExclusiveMutex *muxPtr) { if (*muxPtr != (Sp_ExclusiveMutex_*)0) { Sp_ExclusiveMutex_ *emPtr = *(Sp_ExclusiveMutex_**)muxPtr; if (emPtr->lock) { Tcl_MutexFinalize(&emPtr->lock); } if (emPtr->mutex) { Tcl_MutexFinalize(&emPtr->mutex); } Tcl_Free(*muxPtr); } } /* *---------------------------------------------------------------------- * * Sp_RecursiveMutexLock -- * * Locks the recursive mutex. * * Results: * 1 - mutex is locked (as it always should be) * * Side effects: * None. * *---------------------------------------------------------------------- */ int Sp_RecursiveMutexLock(Sp_RecursiveMutex *muxPtr) { Sp_RecursiveMutex_ *rmPtr; Tcl_ThreadId thisThread = Tcl_GetCurrentThread(); /* * Allocate the mutex structure on first access */ if (*muxPtr == (Sp_RecursiveMutex_*)0) { Tcl_MutexLock(&initMutex); if (*muxPtr == (Sp_RecursiveMutex_*)0) { *muxPtr = (Sp_RecursiveMutex_ *) Tcl_Alloc(sizeof(Sp_RecursiveMutex_)); memset(*muxPtr, 0, sizeof(Sp_RecursiveMutex_)); } Tcl_MutexUnlock(&initMutex); } rmPtr = *(Sp_RecursiveMutex_**)muxPtr; Tcl_MutexLock(&rmPtr->lock); if (rmPtr->owner == thisThread) { /* * We are already holding the mutex * so just count one more lock. */ rmPtr->lockcount++; } else { if (rmPtr->owner == NULL) { /* * Nobody holds the mutex, we do now. */ rmPtr->owner = thisThread; rmPtr->lockcount = 1; } else { /* * Somebody else holds the mutex; wait. */ while (1) { Tcl_ConditionWait(&rmPtr->cond, &rmPtr->lock, NULL); if (rmPtr->owner == NULL) { rmPtr->owner = thisThread; rmPtr->lockcount = 1; break; } } } } Tcl_MutexUnlock(&rmPtr->lock); return 1; } /* *---------------------------------------------------------------------- * * Sp_RecursiveMutexIsLocked -- * * Checks wether the mutex is locked or not. * * Results: * 1 - mutex is locked * 0 - mutex is not locked * * Side effects: * None. * *---------------------------------------------------------------------- */ int Sp_RecursiveMutexIsLocked(Sp_RecursiveMutex *muxPtr) { return AnyMutexIsLocked((Sp_AnyMutex*)*muxPtr, NULL); } /* *---------------------------------------------------------------------- * * Sp_RecursiveMutexUnlock -- * * Unlock the recursive mutex. * * Results: * 1 - mutex unlocked * 0 - mutex never locked * * Side effects: * None. * *---------------------------------------------------------------------- */ int Sp_RecursiveMutexUnlock(Sp_RecursiveMutex *muxPtr) { Sp_RecursiveMutex_ *rmPtr; if (*muxPtr == (Sp_RecursiveMutex_*)0) { return 0; /* Never locked before */ } rmPtr = *(Sp_RecursiveMutex_**)muxPtr; Tcl_MutexLock(&rmPtr->lock); if (rmPtr->lockcount == 0) { Tcl_MutexUnlock(&rmPtr->lock); return 0; /* Not locked now */ } if (--rmPtr->lockcount <= 0) { rmPtr->lockcount = 0; rmPtr->owner = NULL; if (rmPtr->cond) { Tcl_ConditionNotify(&rmPtr->cond); } } Tcl_MutexUnlock(&rmPtr->lock); return 1; } /* *---------------------------------------------------------------------- * * Sp_RecursiveMutexFinalize -- * * Finalize the recursive mutex. It is not safe for two or * more threads to finalize the mutex at the same time. * * Results: * None. * * Side effects: * Mutex is destroyed. * *---------------------------------------------------------------------- */ void Sp_RecursiveMutexFinalize(Sp_RecursiveMutex *muxPtr) { if (*muxPtr != (Sp_RecursiveMutex_*)0) { Sp_RecursiveMutex_ *rmPtr = *(Sp_RecursiveMutex_**)muxPtr; if (rmPtr->lock) { Tcl_MutexFinalize(&rmPtr->lock); } if (rmPtr->cond) { Tcl_ConditionFinalize(&rmPtr->cond); } Tcl_Free(*muxPtr); } } /* *---------------------------------------------------------------------- * * Sp_ReadWriteMutexRLock -- * * Read-locks the reader/writer mutex. * * Results: * 1 - mutex is locked * 0 - mutex is not locked as we already hold the write lock * * Side effects: * None. * *---------------------------------------------------------------------- */ int Sp_ReadWriteMutexRLock(Sp_ReadWriteMutex *muxPtr) { Sp_ReadWriteMutex_ *rwPtr; Tcl_ThreadId thisThread = Tcl_GetCurrentThread(); /* * Allocate the mutex structure on first access */ if (*muxPtr == (Sp_ReadWriteMutex_*)0) { Tcl_MutexLock(&initMutex); if (*muxPtr == (Sp_ReadWriteMutex_*)0) { *muxPtr = (Sp_ReadWriteMutex_ *) Tcl_Alloc(sizeof(Sp_ReadWriteMutex_)); memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_)); } Tcl_MutexUnlock(&initMutex); } rwPtr = *(Sp_ReadWriteMutex_**)muxPtr; Tcl_MutexLock(&rwPtr->lock); if (rwPtr->lockcount == -1 && rwPtr->owner == thisThread) { Tcl_MutexUnlock(&rwPtr->lock); return 0; /* We already hold the write lock */ } while (rwPtr->lockcount < 0) { rwPtr->numrd++; Tcl_ConditionWait(&rwPtr->rcond, &rwPtr->lock, NULL); rwPtr->numrd--; } rwPtr->lockcount++; rwPtr->owner = NULL; /* Many threads can read-lock */ Tcl_MutexUnlock(&rwPtr->lock); return 1; } /* *---------------------------------------------------------------------- * * Sp_ReadWriteMutexWLock -- * * Write-locks the reader/writer mutex. * * Results: * 1 - mutex is locked * 0 - same thread attempts to write-lock the mutex twice * * Side effects: * None. * *---------------------------------------------------------------------- */ int Sp_ReadWriteMutexWLock(Sp_ReadWriteMutex *muxPtr) { Sp_ReadWriteMutex_ *rwPtr; Tcl_ThreadId thisThread = Tcl_GetCurrentThread(); /* * Allocate the mutex structure on first access */ if (*muxPtr == (Sp_ReadWriteMutex_*)0) { Tcl_MutexLock(&initMutex); if (*muxPtr == (Sp_ReadWriteMutex_*)0) { *muxPtr = (Sp_ReadWriteMutex_ *) Tcl_Alloc(sizeof(Sp_ReadWriteMutex_)); memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_)); } Tcl_MutexUnlock(&initMutex); } rwPtr = *(Sp_ReadWriteMutex_**)muxPtr; Tcl_MutexLock(&rwPtr->lock); if (rwPtr->owner == thisThread && rwPtr->lockcount == -1) { Tcl_MutexUnlock(&rwPtr->lock); return 0; /* The same thread attempts to write-lock again */ } while (rwPtr->lockcount != 0) { rwPtr->numwr++; Tcl_ConditionWait(&rwPtr->wcond, &rwPtr->lock, NULL); rwPtr->numwr--; } rwPtr->lockcount = -1; /* This designates the sole writer */ rwPtr->owner = thisThread; /* which is our current thread */ Tcl_MutexUnlock(&rwPtr->lock); return 1; } /* *---------------------------------------------------------------------- * * Sp_ReadWriteMutexIsLocked -- * * Checks wether the mutex is locked or not. * * Results: * 1 - mutex is locked * 0 - mutex is not locked * * Side effects: * None. * *---------------------------------------------------------------------- */ int Sp_ReadWriteMutexIsLocked(Sp_ReadWriteMutex *muxPtr) { return AnyMutexIsLocked((Sp_AnyMutex*)*muxPtr, NULL); } /* *---------------------------------------------------------------------- * * Sp_ReadWriteMutexUnlock -- * * Unlock the reader/writer mutex. * * Results: * None. * * Side effects: * *---------------------------------------------------------------------- */ int Sp_ReadWriteMutexUnlock(Sp_ReadWriteMutex *muxPtr) { Sp_ReadWriteMutex_ *rwPtr; if (*muxPtr == (Sp_ReadWriteMutex_*)0) { return 0; /* Never locked before */ } rwPtr = *(Sp_ReadWriteMutex_**)muxPtr; Tcl_MutexLock(&rwPtr->lock); if (rwPtr->lockcount == 0) { Tcl_MutexUnlock(&rwPtr->lock); return 0; /* Not locked now */ } if (--rwPtr->lockcount <= 0) { rwPtr->lockcount = 0; rwPtr->owner = NULL; } if (rwPtr->numwr) { Tcl_ConditionNotify(&rwPtr->wcond); } else if (rwPtr->numrd) { Tcl_ConditionNotify(&rwPtr->rcond); } Tcl_MutexUnlock(&rwPtr->lock); return 1; } /* *---------------------------------------------------------------------- * * Sp_ReadWriteMutexFinalize -- * * Finalize the reader/writer mutex. It is not safe for two or * more threads to finalize the mutex at the same time. * * Results: * None. * * Side effects: * Mutex is destroyed. * *---------------------------------------------------------------------- */ void Sp_ReadWriteMutexFinalize(Sp_ReadWriteMutex *muxPtr) { if (*muxPtr != (Sp_ReadWriteMutex_*)0) { Sp_ReadWriteMutex_ *rwPtr = *(Sp_ReadWriteMutex_**)muxPtr; if (rwPtr->lock) { Tcl_MutexFinalize(&rwPtr->lock); } if (rwPtr->rcond) { Tcl_ConditionFinalize(&rwPtr->rcond); } if (rwPtr->wcond) { Tcl_ConditionFinalize(&rwPtr->wcond); } Tcl_Free(*muxPtr); } } /* *---------------------------------------------------------------------- * * AnyMutexIsLocked -- * * Checks wether the mutex is locked. If optional threadId * is given (i.e. != 0) it checks if the given thread also * holds the lock. * * Results: * 1 - mutex is locked (optionally by the given thread) * 0 - mutex is not locked (optionally by the given thread) * * Side effects: * None. * *---------------------------------------------------------------------- */ static int AnyMutexIsLocked(Sp_AnyMutex *mPtr, Tcl_ThreadId threadId) { int locked = 0; if (mPtr != NULL) { Tcl_MutexLock(&mPtr->lock); locked = mPtr->lockcount != 0; if (locked && threadId != NULL) { locked = mPtr->owner == threadId; } Tcl_MutexUnlock(&mPtr->lock); } return locked; } /* EOF $RCSfile: threadSpCmd.c,v $ */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/threadPoolCmd.c0000644003604700454610000013342014726633451015623 0ustar dgp771div/* * threadPoolCmd.c -- * * This file implements the Tcl thread pools. * * Copyright (c) 2002 by Zoran Vasiljevic. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * ---------------------------------------------------------------------------- */ #include "tclThreadInt.h" /* * Structure to maintain idle poster threads */ typedef struct TpoolWaiter { Tcl_ThreadId threadId; /* Thread id of the current thread */ struct TpoolWaiter *nextPtr; /* Next structure in the list */ struct TpoolWaiter *prevPtr; /* Previous structure in the list */ } TpoolWaiter; /* * Structure describing an instance of a thread pool. */ typedef struct ThreadPool { Tcl_WideInt jobId; /* Job counter */ int idleTime; /* Time in secs a worker thread idles */ int tearDown; /* Set to 1 to tear down the pool */ int suspend; /* Set to 1 to suspend pool processing */ char *initScript; /* Script to initialize worker thread */ char *exitScript; /* Script to cleanup the worker */ Tcl_WideInt minWorkers; /* Minimum number or worker threads */ Tcl_WideInt maxWorkers; /* Maximum number of worker threads */ Tcl_WideInt numWorkers; /* Current number of worker threads */ Tcl_WideInt idleWorkers; /* Number of idle workers */ size_t refCount; /* Reference counter for reserve/release */ Tcl_Mutex mutex; /* Pool mutex */ Tcl_Condition cond; /* Pool condition variable */ Tcl_HashTable jobsDone; /* Stores processed job results */ struct TpoolResult *workTail; /* Tail of the list with jobs pending*/ struct TpoolResult *workHead; /* Head of the list with jobs pending*/ struct TpoolWaiter *waitTail; /* Tail of the thread waiters list */ struct TpoolWaiter *waitHead; /* Head of the thread waiters list */ struct ThreadPool *nextPtr; /* Next structure in the threadpool list */ struct ThreadPool *prevPtr; /* Previous structure in threadpool list */ } ThreadPool; #define TPOOL_HNDLPREFIX "tpool" /* Prefix to generate Tcl pool handles */ #define TPOOL_MINWORKERS 0 /* Default minimum # of worker threads */ #define TPOOL_MAXWORKERS 4 /* Default maximum # of worker threads */ #define TPOOL_IDLETIMER 0 /* Default worker thread idle timer */ /* * Structure for passing evaluation results */ typedef struct TpoolResult { int detached; /* Result is to be ignored */ Tcl_WideInt jobId; /* The job id of the current job */ char *script; /* Script to evaluate in worker thread */ size_t scriptLen; /* Length of the script */ int retcode; /* Tcl return code of the current job */ char *result; /* Tcl result of the current job */ char *errorCode; /* On error: content of the errorCode */ char *errorInfo; /* On error: content of the errorInfo */ Tcl_ThreadId threadId; /* Originating thread id */ ThreadPool *tpoolPtr; /* Current thread pool */ struct TpoolResult *nextPtr; struct TpoolResult *prevPtr; } TpoolResult; /* * Private structure for each worker/poster thread. */ typedef struct ThreadSpecificData { int stop; /* Set stop event; exit from event loop */ TpoolWaiter *waitPtr; /* Threads private idle structure */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * This global list maintains thread pools. */ static ThreadPool *tpoolList; static Tcl_Mutex listMutex; static Tcl_Mutex startMutex; /* * Used to represent the empty result. */ static char *threadEmptyResult = (char *)""; /* * Functions implementing Tcl commands */ static Tcl_ObjCmdProc2 TpoolCreateObjCmd; static Tcl_ObjCmdProc2 TpoolPostObjCmd; static Tcl_ObjCmdProc2 TpoolWaitObjCmd; static Tcl_ObjCmdProc2 TpoolCancelObjCmd; static Tcl_ObjCmdProc2 TpoolGetObjCmd; static Tcl_ObjCmdProc2 TpoolReserveObjCmd; static Tcl_ObjCmdProc2 TpoolReleaseObjCmd; static Tcl_ObjCmdProc2 TpoolSuspendObjCmd; static Tcl_ObjCmdProc2 TpoolResumeObjCmd; static Tcl_ObjCmdProc2 TpoolNamesObjCmd; /* * Miscelaneous functions used within this file */ static int CreateWorker(Tcl_Interp *interp, ThreadPool *tpoolPtr); static Tcl_ThreadCreateType TpoolWorker(void *clientData); static int RunStopEvent(Tcl_Event *evPtr, int mask); static void PushWork(TpoolResult *rPtr, ThreadPool *tpoolPtr); static TpoolResult* PopWork(ThreadPool *tpoolPtr); static void PushWaiter(ThreadPool *tpoolPtr); static TpoolWaiter* PopWaiter(ThreadPool *tpoolPtr); static void SignalWaiter(ThreadPool *tpoolPtr); static int TpoolEval(Tcl_Interp *interp, char *script, size_t scriptLen, TpoolResult *rPtr); static void SetResult(Tcl_Interp *interp, TpoolResult *rPtr); static ThreadPool* GetTpool(const char *tpoolName); static ThreadPool* GetTpoolUnl(const char *tpoolName); static void ThrExitHandler(void *clientData); static void AppExitHandler(void *clientData); static size_t TpoolReserve(ThreadPool *tpoolPtr); static size_t TpoolRelease(ThreadPool *tpoolPtr); static void TpoolSuspend(ThreadPool *tpoolPtr); static void TpoolResume(ThreadPool *tpoolPtr); static void InitWaiter(void); /* *---------------------------------------------------------------------- * * TpoolCreateObjCmd -- * * This procedure is invoked to process the "tpool::create" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TpoolCreateObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_WideInt ii; Tcl_WideInt minw, maxw; int idle; char buf[64], *exs = NULL, *cmd = NULL; ThreadPool *tpoolPtr; /* * Syntax: tpool::create ?-minworkers count? * ?-maxworkers count? * ?-initcmd script? * ?-exitcmd script? * ?-idletime seconds? */ if (((objc-1) % 2)) { goto usage; } minw = TPOOL_MINWORKERS; maxw = TPOOL_MAXWORKERS; idle = TPOOL_IDLETIMER; /* * Parse the optional arguments */ for (ii = 1; ii < objc; ii += 2) { char *opt = Tcl_GetString(objv[ii]); if (OPT_CMP(opt, "-minworkers")) { if (Tcl_GetWideIntFromObj(interp, objv[ii+1], &minw) != TCL_OK) { return TCL_ERROR; } } else if (OPT_CMP(opt, "-maxworkers")) { if (Tcl_GetWideIntFromObj(interp, objv[ii+1], &maxw) != TCL_OK) { return TCL_ERROR; } } else if (OPT_CMP(opt, "-idletime")) { if (Tcl_GetIntFromObj(interp, objv[ii+1], &idle) != TCL_OK) { return TCL_ERROR; } } else if (OPT_CMP(opt, "-initcmd")) { const char *val = Tcl_GetString(objv[ii+1]); cmd = strcpy((char *)Tcl_Alloc(objv[ii+1]->length+1), val); } else if (OPT_CMP(opt, "-exitcmd")) { const char *val = Tcl_GetString(objv[ii+1]); exs = strcpy((char *)Tcl_Alloc(objv[ii+1]->length+1), val); } else { goto usage; } } /* * Do some consistency checking */ if (minw < 0) { minw = 0; } if (maxw < 0) { maxw = TPOOL_MAXWORKERS; } if (minw > maxw) { maxw = minw; } /* * Allocate and initialize thread pool structure */ tpoolPtr = (ThreadPool *)Tcl_Alloc(sizeof(ThreadPool)); memset(tpoolPtr, 0, sizeof(ThreadPool)); tpoolPtr->minWorkers = minw; tpoolPtr->maxWorkers = maxw; tpoolPtr->idleTime = idle; tpoolPtr->initScript = cmd; tpoolPtr->exitScript = exs; Tcl_InitHashTable(&tpoolPtr->jobsDone, TCL_ONE_WORD_KEYS); Tcl_MutexLock(&listMutex); SpliceIn(tpoolPtr, tpoolList); Tcl_MutexUnlock(&listMutex); /* * Start the required number of worker threads. * On failure to start any of them, tear-down * partially initialized pool. */ Tcl_MutexLock(&tpoolPtr->mutex); for (ii = 0; ii < tpoolPtr->minWorkers; ii++) { if (CreateWorker(interp, tpoolPtr) != TCL_OK) { Tcl_MutexUnlock(&tpoolPtr->mutex); Tcl_MutexLock(&listMutex); TpoolRelease(tpoolPtr); Tcl_MutexUnlock(&listMutex); return TCL_ERROR; } } Tcl_MutexUnlock(&tpoolPtr->mutex); snprintf(buf, sizeof(buf), "%s%p", TPOOL_HNDLPREFIX, tpoolPtr); Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_INDEX_NONE)); return TCL_OK; usage: Tcl_WrongNumArgs(interp, 1, objv, "?-minworkers count? ?-maxworkers count? " "?-initcmd script? ?-exitcmd script? " "?-idletime seconds?"); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TpoolPostObjCmd -- * * This procedure is invoked to process the "tpool::post" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TpoolPostObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_WideInt jobId = 0; int detached = 0, nowait = 0; Tcl_Size ii, len; const char *tpoolName, *script; TpoolResult *rPtr; ThreadPool *tpoolPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Syntax: tpool::post ?-detached? ?-nowait? tpoolId script */ if (objc < 3 || objc > 5) { goto usage; } for (ii = 1; ii < objc; ii++) { char *opt = Tcl_GetString(objv[ii]); if (*opt != '-') { break; } else if (OPT_CMP(opt, "-detached")) { detached = 1; } else if (OPT_CMP(opt, "-nowait")) { nowait = 1; } else { goto usage; } } /* * We expect exactly two arguments remaining after options */ if (objc != 2 + ii) { goto usage; } tpoolName = Tcl_GetString(objv[ii]); script = Tcl_GetStringFromObj(objv[ii+1], &len); tpoolPtr = GetTpool(tpoolName); if (tpoolPtr == NULL) { Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, "\"", (void *)NULL); return TCL_ERROR; } /* * Initialize per-thread private data for this caller */ InitWaiter(); /* * See if any worker available to run the job. */ Tcl_MutexLock(&tpoolPtr->mutex); if (nowait) { if (tpoolPtr->numWorkers == 0) { /* * Assure there is at least one worker running. */ PushWaiter(tpoolPtr); if (CreateWorker(interp, tpoolPtr) != TCL_OK) { Tcl_MutexUnlock(&tpoolPtr->mutex); return TCL_ERROR; } /* * Wait for worker to start while servicing the event loop */ Tcl_MutexUnlock(&tpoolPtr->mutex); tsdPtr->stop = -1; while(tsdPtr->stop == -1) { Tcl_DoOneEvent(TCL_ALL_EVENTS); } Tcl_MutexLock(&tpoolPtr->mutex); } } else { /* * If there are no idle worker threads, start some new * unless we are already running max number of workers. * In that case wait for the next one to become idle. */ while (tpoolPtr->idleWorkers == 0) { PushWaiter(tpoolPtr); if (tpoolPtr->numWorkers < tpoolPtr->maxWorkers) { /* * No more free workers; start new one */ if (CreateWorker(interp, tpoolPtr) != TCL_OK) { Tcl_MutexUnlock(&tpoolPtr->mutex); return TCL_ERROR; } } /* * Wait for worker to start while servicing the event loop */ Tcl_MutexUnlock(&tpoolPtr->mutex); tsdPtr->stop = -1; while(tsdPtr->stop == -1) { Tcl_DoOneEvent(TCL_ALL_EVENTS); } Tcl_MutexLock(&tpoolPtr->mutex); } } /* * Create new job ticket and put it on the list. */ rPtr = (TpoolResult *)Tcl_Alloc(sizeof(TpoolResult)); memset(rPtr, 0, sizeof(TpoolResult)); if (detached == 0) { jobId = ++tpoolPtr->jobId; rPtr->jobId = jobId; } rPtr->script = strcpy((char *)Tcl_Alloc(len+1), script); rPtr->scriptLen = len; rPtr->detached = detached; rPtr->threadId = Tcl_GetCurrentThread(); PushWork(rPtr, tpoolPtr); Tcl_ConditionNotify(&tpoolPtr->cond); Tcl_MutexUnlock(&tpoolPtr->mutex); if (detached == 0) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(jobId)); } return TCL_OK; usage: Tcl_WrongNumArgs(interp, 1, objv, "?-detached? ?-nowait? tpoolId script"); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TpoolWaitObjCmd -- * * This procedure is invoked to process the "tpool::wait" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TpoolWaitObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { int done; Tcl_Size ii, wObjc; Tcl_WideInt jobId; char *tpoolName; Tcl_Obj *listVar = NULL; Tcl_Obj *waitList, *doneList, **wObjv; ThreadPool *tpoolPtr; TpoolResult *rPtr; Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Syntax: tpool::wait tpoolId jobIdList ?listVar? */ if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "tpoolId jobIdList ?listVar"); return TCL_ERROR; } if (objc == 4) { listVar = objv[3]; } if (Tcl_ListObjGetElements(interp, objv[2], &wObjc, &wObjv) != TCL_OK) { return TCL_ERROR; } tpoolName = Tcl_GetString(objv[1]); tpoolPtr = GetTpool(tpoolName); if (tpoolPtr == NULL) { Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, "\"", (void *)NULL); return TCL_ERROR; } InitWaiter(); done = 0; /* Number of elements in the done list */ doneList = Tcl_NewListObj(0, NULL); Tcl_MutexLock(&tpoolPtr->mutex); while (1) { waitList = Tcl_NewListObj(0, NULL); for (ii = 0; ii < wObjc; ii++) { if (Tcl_GetWideIntFromObj(interp, wObjv[ii], &jobId) != TCL_OK) { Tcl_MutexUnlock(&tpoolPtr->mutex); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&tpoolPtr->jobsDone, (void *)(size_t)jobId); if (hPtr) { rPtr = (TpoolResult*)Tcl_GetHashValue(hPtr); } else { rPtr = NULL; } if (rPtr == NULL) { if (listVar) { Tcl_ListObjAppendElement(interp, waitList, wObjv[ii]); } } else if (!rPtr->detached && rPtr->result) { done++; Tcl_ListObjAppendElement(interp, doneList, wObjv[ii]); } else if (listVar) { Tcl_ListObjAppendElement(interp, waitList, wObjv[ii]); } } if (done) { break; } /* * None of the jobs done, wait for completion * of the next job and try again. */ Tcl_DecrRefCount(waitList); PushWaiter(tpoolPtr); Tcl_MutexUnlock(&tpoolPtr->mutex); tsdPtr->stop = -1; while (tsdPtr->stop == -1) { Tcl_DoOneEvent(TCL_ALL_EVENTS); } Tcl_MutexLock(&tpoolPtr->mutex); } Tcl_MutexUnlock(&tpoolPtr->mutex); if (listVar) { Tcl_ObjSetVar2(interp, listVar, NULL, waitList, 0); } Tcl_SetObjResult(interp, doneList); return TCL_OK; } /* *---------------------------------------------------------------------- * * TpoolCancelObjCmd -- * * This procedure is invoked to process the "tpool::cancel" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TpoolCancelObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_Size ii, wObjc; Tcl_WideInt jobId; char *tpoolName; Tcl_Obj *listVar = NULL; Tcl_Obj *doneList, *waitList, **wObjv; ThreadPool *tpoolPtr; TpoolResult *rPtr; /* * Syntax: tpool::cancel tpoolId jobIdList ?listVar? */ if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "tpoolId jobIdList ?listVar"); return TCL_ERROR; } if (objc == 4) { listVar = objv[3]; } if (Tcl_ListObjGetElements(interp, objv[2], &wObjc, &wObjv) != TCL_OK) { return TCL_ERROR; } tpoolName = Tcl_GetString(objv[1]); tpoolPtr = GetTpool(tpoolName); if (tpoolPtr == NULL) { Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, "\"", (void *)NULL); return TCL_ERROR; } InitWaiter(); doneList = Tcl_NewListObj(0, NULL); waitList = Tcl_NewListObj(0, NULL); Tcl_MutexLock(&tpoolPtr->mutex); for (ii = 0; ii < wObjc; ii++) { if (Tcl_GetWideIntFromObj(interp, wObjv[ii], &jobId) != TCL_OK) { return TCL_ERROR; } for (rPtr = tpoolPtr->workHead; rPtr; rPtr = rPtr->nextPtr) { if (rPtr->jobId == jobId) { if (rPtr->prevPtr != NULL) { rPtr->prevPtr->nextPtr = rPtr->nextPtr; } else { tpoolPtr->workHead = rPtr->nextPtr; } if (rPtr->nextPtr != NULL) { rPtr->nextPtr->prevPtr = rPtr->prevPtr; } else { tpoolPtr->workTail = rPtr->prevPtr; } SetResult(NULL, rPtr); /* Just to free the result */ Tcl_Free(rPtr->script); Tcl_Free(rPtr); Tcl_ListObjAppendElement(interp, doneList, wObjv[ii]); break; } } if (rPtr == NULL && listVar) { Tcl_ListObjAppendElement(interp, waitList, wObjv[ii]); } } Tcl_MutexUnlock(&tpoolPtr->mutex); if (listVar) { Tcl_ObjSetVar2(interp, listVar, NULL, waitList, 0); } Tcl_SetObjResult(interp, doneList); return TCL_OK; } /* *---------------------------------------------------------------------- * * TpoolGetObjCmd -- * * This procedure is invoked to process the "tpool::get" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TpoolGetObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { int ret; Tcl_WideInt jobId; char *tpoolName; Tcl_Obj *resVar = NULL; ThreadPool *tpoolPtr; TpoolResult *rPtr; Tcl_HashEntry *hPtr; /* * Syntax: tpool::get tpoolId jobId ?result? */ if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "tpoolId jobId ?result?"); return TCL_ERROR; } if (Tcl_GetWideIntFromObj(interp, objv[2], &jobId) != TCL_OK) { return TCL_ERROR; } if (objc == 4) { resVar = objv[3]; } /* * Locate the threadpool */ tpoolName = Tcl_GetString(objv[1]); tpoolPtr = GetTpool(tpoolName); if (tpoolPtr == NULL) { Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, "\"", (void *)NULL); return TCL_ERROR; } /* * Locate the job in question. It is an error to * do a "get" on bogus job handle or on the job * which did not complete yet. */ Tcl_MutexLock(&tpoolPtr->mutex); hPtr = Tcl_FindHashEntry(&tpoolPtr->jobsDone, (void *)(size_t)jobId); if (hPtr == NULL) { Tcl_MutexUnlock(&tpoolPtr->mutex); Tcl_AppendResult(interp, "no such job", (void *)NULL); return TCL_ERROR; } rPtr = (TpoolResult*)Tcl_GetHashValue(hPtr); if (rPtr->result == NULL) { Tcl_MutexUnlock(&tpoolPtr->mutex); Tcl_AppendResult(interp, "job not completed", (void *)NULL); return TCL_ERROR; } Tcl_DeleteHashEntry(hPtr); Tcl_MutexUnlock(&tpoolPtr->mutex); ret = rPtr->retcode; SetResult(interp, rPtr); Tcl_Free(rPtr); if (resVar) { Tcl_ObjSetVar2(interp, resVar, NULL, Tcl_GetObjResult(interp), 0); Tcl_SetObjResult(interp, Tcl_NewIntObj(ret)); ret = TCL_OK; } return ret; } /* *---------------------------------------------------------------------- * * TpoolReserveObjCmd -- * * This procedure is invoked to process the "tpool::preserve" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TpoolReserveObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { size_t ret; char *tpoolName; ThreadPool *tpoolPtr; /* * Syntax: tpool::preserve tpoolId */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "tpoolId"); return TCL_ERROR; } tpoolName = Tcl_GetString(objv[1]); Tcl_MutexLock(&listMutex); tpoolPtr = GetTpoolUnl(tpoolName); if (tpoolPtr == NULL) { Tcl_MutexUnlock(&listMutex); Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, "\"", (void *)NULL); return TCL_ERROR; } ret = TpoolReserve(tpoolPtr); Tcl_MutexUnlock(&listMutex); Tcl_SetObjResult(interp, Tcl_NewIntObj((Tcl_WideInt)ret)); return TCL_OK; } /* *---------------------------------------------------------------------- * * TpoolReleaseObjCmd -- * * This procedure is invoked to process the "tpool::release" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TpoolReleaseObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { size_t ret; char *tpoolName; ThreadPool *tpoolPtr; /* * Syntax: tpool::release tpoolId */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "tpoolId"); return TCL_ERROR; } tpoolName = Tcl_GetString(objv[1]); Tcl_MutexLock(&listMutex); tpoolPtr = GetTpoolUnl(tpoolName); if (tpoolPtr == NULL) { Tcl_MutexUnlock(&listMutex); Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, "\"", (void *)NULL); return TCL_ERROR; } ret = TpoolRelease(tpoolPtr); Tcl_MutexUnlock(&listMutex); Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)ret)); return TCL_OK; } /* *---------------------------------------------------------------------- * * TpoolSuspendObjCmd -- * * This procedure is invoked to process the "tpool::suspend" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TpoolSuspendObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { char *tpoolName; ThreadPool *tpoolPtr; /* * Syntax: tpool::suspend tpoolId */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "tpoolId"); return TCL_ERROR; } tpoolName = Tcl_GetString(objv[1]); tpoolPtr = GetTpool(tpoolName); if (tpoolPtr == NULL) { Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, "\"", (void *)NULL); return TCL_ERROR; } TpoolSuspend(tpoolPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TpoolResumeObjCmd -- * * This procedure is invoked to process the "tpool::resume" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TpoolResumeObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { char *tpoolName; ThreadPool *tpoolPtr; /* * Syntax: tpool::resume tpoolId */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "tpoolId"); return TCL_ERROR; } tpoolName = Tcl_GetString(objv[1]); tpoolPtr = GetTpool(tpoolName); if (tpoolPtr == NULL) { Tcl_AppendResult(interp, "can not find threadpool \"", tpoolName, "\"", (void *)NULL); return TCL_ERROR; } TpoolResume(tpoolPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TpoolNamesObjCmd -- * * This procedure is invoked to process the "tpool::names" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int TpoolNamesObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { ThreadPool *tpoolPtr; Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); (void)objc; (void)objv; Tcl_MutexLock(&listMutex); for (tpoolPtr = tpoolList; tpoolPtr; tpoolPtr = tpoolPtr->nextPtr) { char buf[32]; snprintf(buf, sizeof(buf), "%s%p", TPOOL_HNDLPREFIX, tpoolPtr); Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(buf, TCL_INDEX_NONE)); } Tcl_MutexUnlock(&listMutex); Tcl_SetObjResult(interp, listObj); return TCL_OK; } /* *---------------------------------------------------------------------- * * CreateWorker -- * * Creates new worker thread for the given pool. Assumes the caller * holds the pool mutex. * * Results: * None. * * Side effects: * Informs waiter thread (if any) about the new worker thread. * *---------------------------------------------------------------------- */ static int CreateWorker( Tcl_Interp *interp, ThreadPool *tpoolPtr ) { Tcl_ThreadId id; TpoolResult result; /* * Initialize the result structure to be * passed to the new thread. This is used * as communication to and from the thread. */ memset(&result, 0, sizeof(TpoolResult)); result.retcode = -1; result.tpoolPtr = tpoolPtr; /* * Create new worker thread here. Wait for the thread to start * because it's using the ThreadResult arg which is on our stack. */ Tcl_MutexLock(&startMutex); if (Tcl_CreateThread(&id, TpoolWorker, &result, TCL_THREAD_STACK_DEFAULT, 0) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create a new thread", TCL_INDEX_NONE)); Tcl_MutexUnlock(&startMutex); return TCL_ERROR; } while(result.retcode == -1) { Tcl_ConditionWait(&tpoolPtr->cond, &startMutex, NULL); } Tcl_MutexUnlock(&startMutex); /* * Set error-related information if the thread * failed to initialize correctly. */ if (result.retcode == 1) { result.retcode = TCL_ERROR; SetResult(interp, &result); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * TpoolWorker -- * * This is the main function of each of the threads in the pool. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static Tcl_ThreadCreateType TpoolWorker( void *clientData ) { TpoolResult *rPtr = (TpoolResult *)clientData; ThreadPool *tpoolPtr = rPtr->tpoolPtr; int tout = 0; Tcl_Interp *interp; Tcl_Time waitTime, *idlePtr; const char *errMsg; Tcl_MutexLock(&startMutex); /* * Initialize the Tcl interpreter */ #ifdef NS_AOLSERVER interp = (Tcl_Interp*)Ns_TclAllocateInterp(NULL); rPtr->retcode = 0; #else interp = Tcl_CreateInterp(); if (Tcl_Init(interp) != TCL_OK) { rPtr->retcode = 1; } else if (Thread_Init(interp) != TCL_OK) { rPtr->retcode = 1; } else { rPtr->retcode = 0; } #endif if (rPtr->retcode == 1) { errMsg = Tcl_GetString(Tcl_GetObjResult(interp)); rPtr->result = strcpy((char *)Tcl_Alloc(strlen(errMsg)+1), errMsg); Tcl_ConditionNotify(&tpoolPtr->cond); Tcl_MutexUnlock(&startMutex); goto out; } /* * Initialize the interpreter */ if (tpoolPtr->initScript) { TpoolEval(interp, tpoolPtr->initScript, TCL_INDEX_NONE, rPtr); if (rPtr->retcode != TCL_OK) { rPtr->retcode = 1; errMsg = Tcl_GetString(Tcl_GetObjResult(interp)); rPtr->result = strcpy((char *)Tcl_Alloc(strlen(errMsg)+1), errMsg); Tcl_ConditionNotify(&tpoolPtr->cond); Tcl_MutexUnlock(&startMutex); goto out; } } /* * Setup idle timer */ if (tpoolPtr->idleTime == 0) { idlePtr = NULL; } else { waitTime.sec = tpoolPtr->idleTime; waitTime.usec = 0; idlePtr = &waitTime; } /* * Tell caller we've started */ tpoolPtr->numWorkers++; Tcl_ConditionNotify(&tpoolPtr->cond); Tcl_MutexUnlock(&startMutex); /* * Wait for jobs to arrive. Note the handcrafted time test. * Tcl API misses the return value of the Tcl_ConditionWait(). * Hence, we do not know why the call returned. Was it someone * signalled the variable or has the idle timer expired? */ Tcl_MutexLock(&tpoolPtr->mutex); while (!tpoolPtr->tearDown) { SignalWaiter(tpoolPtr); tpoolPtr->idleWorkers++; rPtr = NULL; tout = 0; while (tpoolPtr->suspend || (!tpoolPtr->tearDown && !tout && (rPtr = PopWork(tpoolPtr)) == NULL)) { if (tpoolPtr->suspend && rPtr == NULL) { Tcl_ConditionWait(&tpoolPtr->cond, &tpoolPtr->mutex, NULL); } else if (rPtr == NULL) { Tcl_Time t1, t2; Tcl_GetTime(&t1); Tcl_ConditionWait(&tpoolPtr->cond, &tpoolPtr->mutex, idlePtr); Tcl_GetTime(&t2); if (tpoolPtr->idleTime > 0) { tout = (t2.sec - t1.sec) >= tpoolPtr->idleTime; } } } tpoolPtr->idleWorkers--; if (rPtr == NULL) { if (tpoolPtr->numWorkers > tpoolPtr->minWorkers) { break; /* Enough workers, can safely kill this one */ } else { continue; /* Worker count at min, leave this one alive */ } } else if (tpoolPtr->tearDown) { PushWork(rPtr, tpoolPtr); break; /* Kill worker because pool is going down */ } Tcl_MutexUnlock(&tpoolPtr->mutex); TpoolEval(interp, rPtr->script, rPtr->scriptLen, rPtr); Tcl_Free(rPtr->script); Tcl_MutexLock(&tpoolPtr->mutex); if (!rPtr->detached) { int isNew; Tcl_SetHashValue(Tcl_CreateHashEntry(&tpoolPtr->jobsDone, (void *)(size_t)rPtr->jobId, &isNew), rPtr); SignalWaiter(tpoolPtr); } else { Tcl_Free(rPtr); } } /* * Tear down the worker */ if (tpoolPtr->exitScript) { TpoolEval(interp, tpoolPtr->exitScript, TCL_INDEX_NONE, NULL); } tpoolPtr->numWorkers--; SignalWaiter(tpoolPtr); Tcl_MutexUnlock(&tpoolPtr->mutex); out: #ifdef NS_AOLSERVER Ns_TclMarkForDelete(interp); Ns_TclDeAllocateInterp(interp); #else Tcl_DeleteInterp(interp); #endif Tcl_ExitThread(0); TCL_THREAD_CREATE_RETURN; } /* *---------------------------------------------------------------------- * * RunStopEvent -- * * Signalizes the waiter thread to stop waiting. * * Results: * 1 (always) * * Side effects: * None. * *---------------------------------------------------------------------- */ static int RunStopEvent( TCL_UNUSED(Tcl_Event *), TCL_UNUSED(int) ) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->stop = 1; return 1; } /* *---------------------------------------------------------------------- * * PushWork -- * * Adds a worker thread to the end of the workers list. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void PushWork( TpoolResult *rPtr, ThreadPool *tpoolPtr ) { SpliceIn(rPtr, tpoolPtr->workHead); if (tpoolPtr->workTail == NULL) { tpoolPtr->workTail = rPtr; } } /* *---------------------------------------------------------------------- * * PopWork -- * * Pops the work ticket from the list * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static TpoolResult * PopWork( ThreadPool *tpoolPtr ) { TpoolResult *rPtr = tpoolPtr->workTail; if (rPtr == NULL) { return NULL; } tpoolPtr->workTail = rPtr->prevPtr; SpliceOut(rPtr, tpoolPtr->workHead); rPtr->nextPtr = rPtr->prevPtr = NULL; return rPtr; } /* *---------------------------------------------------------------------- * * PushWaiter -- * * Adds a waiter thread to the end of the waiters list. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void PushWaiter( ThreadPool *tpoolPtr ) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); SpliceIn(tsdPtr->waitPtr, tpoolPtr->waitHead); if (tpoolPtr->waitTail == NULL) { tpoolPtr->waitTail = tsdPtr->waitPtr; } } /* *---------------------------------------------------------------------- * * PopWaiter -- * * Pops the first waiter from the head of the waiters list. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static TpoolWaiter* PopWaiter( ThreadPool *tpoolPtr ) { TpoolWaiter *waitPtr = tpoolPtr->waitTail; if (waitPtr == NULL) { return NULL; } tpoolPtr->waitTail = waitPtr->prevPtr; SpliceOut(waitPtr, tpoolPtr->waitHead); waitPtr->prevPtr = waitPtr->nextPtr = NULL; return waitPtr; } /* *---------------------------------------------------------------------- * * GetTpool * * Parses the Tcl threadpool handle and locates the * corresponding threadpool maintenance structure. * * Results: * Pointer to the threadpool struct or NULL if none found, * * Side effects: * None. * *---------------------------------------------------------------------- */ static ThreadPool* GetTpool( const char *tpoolName ) { ThreadPool *tpoolPtr; Tcl_MutexLock(&listMutex); tpoolPtr = GetTpoolUnl(tpoolName); Tcl_MutexUnlock(&listMutex); return tpoolPtr; } /* *---------------------------------------------------------------------- * * GetTpoolUnl * * Parses the threadpool handle and locates the * corresponding threadpool maintenance structure. * Assumes caller holds the listMutex, * * Results: * Pointer to the threadpool struct or NULL if none found, * * Side effects: * None. * *---------------------------------------------------------------------- */ static ThreadPool* GetTpoolUnl ( const char *tpoolName ) { ThreadPool *tpool; ThreadPool *tpoolPtr = NULL; if (sscanf(tpoolName, TPOOL_HNDLPREFIX"%p", &tpool) != 1) { return NULL; } for (tpoolPtr = tpoolList; tpoolPtr; tpoolPtr = tpoolPtr->nextPtr) { if (tpoolPtr == tpool) { break; } } return tpoolPtr; } /* *---------------------------------------------------------------------- * * TpoolEval * * Evaluates the script and fills in the result structure. * * Results: * Standard Tcl result, * * Side effects: * Many, depending on the script. * *---------------------------------------------------------------------- */ static int TpoolEval( Tcl_Interp *interp, char *script, size_t scriptLen, TpoolResult *rPtr ) { int ret; Tcl_Size reslen; const char *result; const char *errorCode, *errorInfo; ret = Tcl_EvalEx(interp, script, scriptLen, TCL_EVAL_GLOBAL); if (rPtr == NULL || rPtr->detached) { return ret; } rPtr->retcode = ret; if (ret == TCL_ERROR) { errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY); errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); if (errorCode != NULL) { rPtr->errorCode = (char *)Tcl_Alloc(1 + strlen(errorCode)); strcpy(rPtr->errorCode, errorCode); } if (errorInfo != NULL) { rPtr->errorInfo = (char *)Tcl_Alloc(1 + strlen(errorInfo)); strcpy(rPtr->errorInfo, errorInfo); } } result = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &reslen); if (reslen == 0) { rPtr->result = threadEmptyResult; } else { rPtr->result = strcpy((char *)Tcl_Alloc(1 + reslen), result); } return ret; } /* *---------------------------------------------------------------------- * * SetResult * * Sets the result in current interpreter. * * Results: * Standard Tcl result, * * Side effects: * None. * *---------------------------------------------------------------------- */ static void SetResult( Tcl_Interp *interp, TpoolResult *rPtr ) { if (rPtr->retcode == TCL_ERROR) { if (rPtr->errorCode) { if (interp) { Tcl_SetObjErrorCode(interp,Tcl_NewStringObj(rPtr->errorCode, TCL_INDEX_NONE)); } Tcl_Free(rPtr->errorCode); rPtr->errorCode = NULL; } if (rPtr->errorInfo) { if (interp) { Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(rPtr->errorInfo, TCL_INDEX_NONE)); } Tcl_Free(rPtr->errorInfo); rPtr->errorInfo = NULL; } } if (rPtr->result) { if (rPtr->result == threadEmptyResult) { if (interp) { Tcl_ResetResult(interp); } } else { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj(rPtr->result, TCL_INDEX_NONE)); } Tcl_Free(rPtr->result); rPtr->result = NULL; } } } /* *---------------------------------------------------------------------- * * TpoolReserve -- * * Does the pool preserve and/or release. Assumes caller holds * the listMutex. * * Results: * None. * * Side effects: * May tear-down the threadpool if refcount drops to 0 or below. * *---------------------------------------------------------------------- */ static size_t TpoolReserve( ThreadPool *tpoolPtr ) { return ++tpoolPtr->refCount; } /* *---------------------------------------------------------------------- * * TpoolRelease -- * * Does the pool preserve and/or release. Assumes caller holds * the listMutex. * * Results: * None. * * Side effects: * May tear-down the threadpool if refcount drops to 0 or below. * *---------------------------------------------------------------------- */ static size_t TpoolRelease( ThreadPool *tpoolPtr ) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); TpoolResult *rPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch search; if (tpoolPtr->refCount-- > 1) { return tpoolPtr->refCount; } /* * Pool is going away; remove from the list of pools, */ SpliceOut(tpoolPtr, tpoolList); InitWaiter(); /* * Signal and wait for all workers to die. */ Tcl_MutexLock(&tpoolPtr->mutex); tpoolPtr->tearDown = 1; while (tpoolPtr->numWorkers > 0) { PushWaiter(tpoolPtr); Tcl_ConditionNotify(&tpoolPtr->cond); Tcl_MutexUnlock(&tpoolPtr->mutex); tsdPtr->stop = -1; while(tsdPtr->stop == -1) { Tcl_DoOneEvent(TCL_ALL_EVENTS); } Tcl_MutexLock(&tpoolPtr->mutex); } Tcl_MutexUnlock(&tpoolPtr->mutex); /* * Tear down the pool structure */ if (tpoolPtr->initScript) { Tcl_Free(tpoolPtr->initScript); } if (tpoolPtr->exitScript) { Tcl_Free(tpoolPtr->exitScript); } /* * Cleanup completed but not collected jobs */ hPtr = Tcl_FirstHashEntry(&tpoolPtr->jobsDone, &search); while (hPtr != NULL) { rPtr = (TpoolResult*)Tcl_GetHashValue(hPtr); if (rPtr->result && rPtr->result != threadEmptyResult) { Tcl_Free(rPtr->result); } if (rPtr->retcode == TCL_ERROR) { if (rPtr->errorInfo) { Tcl_Free(rPtr->errorInfo); } if (rPtr->errorCode) { Tcl_Free(rPtr->errorCode); } } Tcl_Free(rPtr); Tcl_DeleteHashEntry(hPtr); hPtr = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(&tpoolPtr->jobsDone); /* * Cleanup jobs posted but never completed. */ for (rPtr = tpoolPtr->workHead; rPtr; rPtr = rPtr->nextPtr) { Tcl_Free(rPtr->script); Tcl_Free(rPtr); } Tcl_MutexFinalize(&tpoolPtr->mutex); Tcl_ConditionFinalize(&tpoolPtr->cond); Tcl_Free(tpoolPtr); return 0; } /* *---------------------------------------------------------------------- * * TpoolSuspend -- * * Marks the pool as suspended. This prevents pool workers to drain * the pool work queue. * * Results: * Value of the suspend flag (1 always). * * Side effects: * During the suspended state, pool worker threads wlll not timeout * even if the worker inactivity timer has been configured. * *---------------------------------------------------------------------- */ static void TpoolSuspend( ThreadPool *tpoolPtr ) { Tcl_MutexLock(&tpoolPtr->mutex); tpoolPtr->suspend = 1; Tcl_MutexUnlock(&tpoolPtr->mutex); } /* *---------------------------------------------------------------------- * * TpoolResume -- * * Clears the pool suspended state. This allows pool workers to drain * the pool work queue again. * * Results: * None. * * Side effects: * Pool workers may be started or awaken. * *---------------------------------------------------------------------- */ static void TpoolResume( ThreadPool *tpoolPtr ) { Tcl_MutexLock(&tpoolPtr->mutex); tpoolPtr->suspend = 0; Tcl_ConditionNotify(&tpoolPtr->cond); Tcl_MutexUnlock(&tpoolPtr->mutex); } /* *---------------------------------------------------------------------- * * SignalWaiter -- * * Signals the waiter thread. * * Results: * None. * * Side effects: * The waiter thread will exit from the event loop. * *---------------------------------------------------------------------- */ static void SignalWaiter( ThreadPool *tpoolPtr ) { TpoolWaiter *waitPtr; Tcl_Event *evPtr; waitPtr = PopWaiter(tpoolPtr); if (waitPtr == NULL) { return; } evPtr = (Tcl_Event *)Tcl_Alloc(sizeof(Tcl_Event)); evPtr->proc = RunStopEvent; Tcl_ThreadQueueEvent(waitPtr->threadId,(Tcl_Event*)evPtr,TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY); } /* *---------------------------------------------------------------------- * * InitWaiter -- * * Setup poster thread to be able to wait in the event loop. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void InitWaiter () { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->waitPtr == NULL) { tsdPtr->waitPtr = (TpoolWaiter *)Tcl_Alloc(sizeof(TpoolWaiter)); tsdPtr->waitPtr->prevPtr = NULL; tsdPtr->waitPtr->nextPtr = NULL; tsdPtr->waitPtr->threadId = Tcl_GetCurrentThread(); Tcl_CreateThreadExitHandler(ThrExitHandler, tsdPtr); } } /* *---------------------------------------------------------------------- * * ThrExitHandler -- * * Performs cleanup when a caller (poster) thread exits. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void ThrExitHandler( void *clientData ) { ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData; Tcl_Free(tsdPtr->waitPtr); } /* *---------------------------------------------------------------------- * * AppExitHandler * * Deletes all threadpools on application exit. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void AppExitHandler( TCL_UNUSED(void *) ) { ThreadPool *tpoolPtr; Tcl_MutexLock(&listMutex); /* * Restart with head of list each time until empty. [Bug 1427570] */ for (tpoolPtr = tpoolList; tpoolPtr; tpoolPtr = tpoolList) { TpoolRelease(tpoolPtr); } Tcl_MutexUnlock(&listMutex); } /* *---------------------------------------------------------------------- * * TpoolInit -- * * Create commands in current interpreter. * * Results: * None. * * Side effects: * On first load, creates application exit handler to clean up * any threadpools left. * *---------------------------------------------------------------------- */ const char * TpoolInit ( Tcl_Interp *interp /* Interp where to create cmds */ ) { static int initialized; TCL_CMD(interp, TPOOL_CMD_PREFIX"create", TpoolCreateObjCmd); TCL_CMD(interp, TPOOL_CMD_PREFIX"names", TpoolNamesObjCmd); TCL_CMD(interp, TPOOL_CMD_PREFIX"post", TpoolPostObjCmd); TCL_CMD(interp, TPOOL_CMD_PREFIX"wait", TpoolWaitObjCmd); TCL_CMD(interp, TPOOL_CMD_PREFIX"cancel", TpoolCancelObjCmd); TCL_CMD(interp, TPOOL_CMD_PREFIX"get", TpoolGetObjCmd); TCL_CMD(interp, TPOOL_CMD_PREFIX"preserve", TpoolReserveObjCmd); TCL_CMD(interp, TPOOL_CMD_PREFIX"release", TpoolReleaseObjCmd); TCL_CMD(interp, TPOOL_CMD_PREFIX"suspend", TpoolSuspendObjCmd); TCL_CMD(interp, TPOOL_CMD_PREFIX"resume", TpoolResumeObjCmd); if (initialized == 0) { Tcl_MutexLock(&listMutex); if (initialized == 0) { Tcl_CreateExitHandler(AppExitHandler, (void *)-1); initialized = 1; } Tcl_MutexUnlock(&listMutex); } return NULL; } /* EOF $RCSfile: threadPoolCmd.c,v $ */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/threadNs.c0000644003604700454610000000420114726633451014640 0ustar dgp771div/* * threadNs.c -- * * Adds interface for loading the extension into the NaviServer/AOLserver. * * Copyright (c) 2002 by Zoran Vasiljevic. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * --------------------------------------------------------------------------- */ #ifdef NS_AOLSERVER #include #include "tclThreadInt.h" int Ns_ModuleVersion = 1; /* *---------------------------------------------------------------------------- * * NsThread_Init -- * * Loads the package for the first time, i.e. in the startup thread. * * Results: * Standard Tcl result * * Side effects: * Package initialized. Tcl commands created. * *---------------------------------------------------------------------------- */ static int NsThread_Init(Tcl_Interp *interp, const void *cd) { NsThreadInterpData *md = (NsThreadInterpData *)cd; int ret = Thread_Init(interp); if (ret != TCL_OK) { Ns_Log(Warning, "can't load module %s: %s", md->modname, Tcl_GetString(Tcl_GetObjResult(interp))); return TCL_ERROR; } Tcl_SetAssocData(interp, "thread:nsd", NULL, md); return TCL_OK; } /* *---------------------------------------------------------------------------- * * Ns_ModuleInit -- * * Called by the NaviServer/AOLserver when loading shared object file. * * Results: * Standard NaviServer/AOLserver result * * Side effects: * Many. Depends on the package. * *---------------------------------------------------------------------------- */ int Ns_ModuleInit(char *srv, char *mod) { NsThreadInterpData *md = NULL; md = (NsThreadInterpData *)ns_malloc(sizeof(NsThreadInterpData)); md->modname = strcpy(ns_malloc(strlen(mod) + 1), mod); md->server = strcpy(ns_malloc(strlen(srv) + 1), srv); return Ns_TclRegisterTrace(srv, NsThread_Init, md, NS_TCL_TRACE_CREATE); } #endif /* NS_AOLSERVER */ /* EOF $RCSfile: aolstub.cpp,v $ */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/threadCmd.c0000644003604700454610000030676514726633451015007 0ustar dgp771div/* * threadCmd.c -- * * This file implements the Tcl thread commands that allow script * level access to threading. It will not load into a core that was * not compiled for thread support. * * See http://www.tcl.tk/doc/howto/thread_model.html * * Some of this code is based on work done by Richard Hipp on behalf of * Conservation Through Innovation, Limited, with their permission. * * Copyright (c) 1998 by Sun Microsystems, Inc. * Copyright (c) 1999,2000 by Scriptics Corporation. * Copyright (c) 2002 by Zoran Vasiljevic. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * ---------------------------------------------------------------------------- */ #include "tclThreadInt.h" #include "threadSvCmd.h" #include "threadUuid.h" /* * Provide package version in build contexts which do not provide * -DPACKAGE_VERSION, like building a shell with the Thread object * files built as part of that shell. Example: basekits. */ #ifndef PACKAGE_VERSION #define PACKAGE_VERSION "3.0.1" #endif /* * Access to the list of threads and to the thread send results * (defined below) is guarded by this mutex. */ TCL_DECLARE_MUTEX(threadMutex) /* * Each thread has an single instance of the following structure. There * is one instance of this structure per thread even if that thread contains * multiple interpreters. The interpreter identified by this structure is * the main interpreter for the thread. The main interpreter is the one that * will process any messages received by a thread. Any interpreter can send * messages but only the main interpreter can receive them, unless you're * not doing asynchronous script backfiring. In such cases the caller might * signal the thread to which interpreter the result should be delivered. */ typedef struct ThreadSpecificData { Tcl_ThreadId threadId; /* The real ID of this thread */ Tcl_Interp *interp; /* Main interp for this thread */ Tcl_Condition doOneEvent; /* Signalled just before running an event from the event loop */ int flags; /* One of the ThreadFlags below */ size_t refCount; /* Used for thread reservation */ int eventsPending; /* # of unprocessed events */ int maxEventsCount; /* Maximum # of pending events */ struct ThreadEventResult *result; struct ThreadSpecificData *nextPtr; struct ThreadSpecificData *prevPtr; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #define THREAD_FLAGS_NONE 0 /* None */ #define THREAD_FLAGS_STOPPED 1 /* Thread is being stopped */ #define THREAD_FLAGS_INERROR 2 /* Thread is in error */ #define THREAD_FLAGS_UNWINDONERROR 4 /* Thread unwinds on script error */ #define THREAD_RESERVE 1 /* Reserves the thread */ #define THREAD_RELEASE 2 /* Releases the thread */ /* * Length of storage for building the Tcl handle for the thread. */ #define THREAD_HNDLPREFIX "tid" #define THREAD_HNDLMAXLEN 32 /* * This list is used to list all threads that have interpreters. */ static struct ThreadSpecificData *threadList = NULL; /* * Used to represent the empty result. */ static char *threadEmptyResult = (char *)""; /* * An instance of the following structure contains all information that is * passed into a new thread when the thread is created using either the * "thread create" Tcl command or the ThreadCreate() C function. */ typedef struct ThreadCtrl { char *script; /* Script to execute */ int flags; /* Initial value of the "flags" * field in ThreadSpecificData */ Tcl_Condition condWait; /* Condition variable used to * sync parent and child threads */ void *cd; /* Opaque ptr to pass to thread */ } ThreadCtrl; /* * Structure holding result of the command executed in target thread. */ typedef struct ThreadEventResult { Tcl_Condition done; /* Set when the script completes */ int code; /* Return value of the function */ char *result; /* Result from the function */ char *errorInfo; /* Copy of errorInfo variable */ char *errorCode; /* Copy of errorCode variable */ Tcl_ThreadId srcThreadId; /* Id of sender, if it dies */ Tcl_ThreadId dstThreadId; /* Id of target, if it dies */ struct ThreadEvent *eventPtr; /* Back pointer */ struct ThreadEventResult *nextPtr; /* List for cleanup */ struct ThreadEventResult *prevPtr; } ThreadEventResult; /* * This list links all active ThreadEventResult structures. This way * an exiting thread can inform all threads waiting on jobs posted to * his event queue that it is dying, so they might stop waiting. */ static ThreadEventResult *resultList; /* * This is the event used to send commands to other threads. */ typedef struct ThreadEvent { Tcl_Event event; /* Must be first */ struct ThreadSendData *sendData; /* See below */ struct ThreadClbkData *clbkData; /* See below */ struct ThreadEventResult *resultPtr; /* To communicate the result back. * NULL if we don't care about it */ } ThreadEvent; typedef int (ThreadSendProc) (Tcl_Interp*, void *); typedef void (ThreadSendFree) (void *); static ThreadSendProc ThreadSendEval; /* Does a regular Tcl_Eval */ static ThreadSendProc ThreadClbkSetVar; /* Sets the named variable */ static ThreadSendProc ThreadClbkCommand; /* Sets the named variable */ /* * These structures are used to communicate commands between source and target * threads. The ThreadSendData is used for source->target command passing, * while the ThreadClbkData is used for doing asynchronous callbacks. * * Important: structures below must have first three elements identical! */ typedef struct ThreadSendData { ThreadSendProc *execProc; /* Func to exec in remote thread */ void *clientData; /* Ptr to pass to send function */ ThreadSendFree *freeProc; /* Function to free client data */ /* ---- */ Tcl_Interp *interp; /* Interp to run the command */ } ThreadSendData; typedef struct ThreadClbkData { ThreadSendProc *execProc; /* The callback function */ void *clientData; /* Ptr to pass to clbk function */ ThreadSendFree *freeProc; /* Function to free client data */ /* ---- */ Tcl_Interp *interp; /* Interp to run the command */ Tcl_ThreadId threadId; /* Thread where to post callback */ ThreadEventResult result; /* Returns result asynchronously */ } ThreadClbkData; /* * Event used to transfer a channel between threads. */ typedef struct TransferEvent { Tcl_Event event; /* Must be first */ Tcl_Channel chan; /* The channel to transfer */ struct TransferResult *resultPtr; /* To communicate the result */ } TransferEvent; typedef struct TransferResult { Tcl_Condition done; /* Set when transfer is done */ int resultCode; /* Set to TCL_OK or TCL_ERROR when the transfer is done. Def = -1 */ char *resultMsg; /* Initialized to NULL. Set to a allocated string by the target thread in case of an error */ Tcl_ThreadId srcThreadId; /* Id of src thread, if it dies */ Tcl_ThreadId dstThreadId; /* Id of tgt thread, if it dies */ struct TransferEvent *eventPtr; /* Back pointer */ struct TransferResult *nextPtr; /* Next in the linked list */ struct TransferResult *prevPtr; /* Previous in the linked list */ } TransferResult; static TransferResult *transferList; /* * This is for simple error handling when a thread script exits badly. */ static Tcl_ThreadId errorThreadId; /* Id of thread to post error message */ static char *errorProcString; /* Tcl script to run when reporting error */ /* * Definition of flags for ThreadSend. */ #define THREAD_SEND_WAIT (1<<1) #define THREAD_SEND_HEAD (1<<2) #define THREAD_SEND_CLBK (1<<3) #ifdef BUILD_thread # undef TCL_STORAGE_CLASS # define TCL_STORAGE_CLASS DLLEXPORT #endif /* * Miscellaneous functions used within this file */ static Tcl_EventDeleteProc ThreadDeleteEvent; static Tcl_ThreadCreateType NewThread(void *clientData); static ThreadSpecificData* ThreadExistsInner(Tcl_ThreadId id); static const char * ThreadInit(Tcl_Interp *interp); static int ThreadCreate(Tcl_Interp *interp, const char *script, TCL_HASH_TYPE stacksize, int flags, int preserve); static int ThreadSend(Tcl_Interp *interp, Tcl_ThreadId id, ThreadSendData *sendPtr, ThreadClbkData *clbkPtr, int flags); static void ThreadSetResult(Tcl_Interp *interp, int code, ThreadEventResult *resultPtr); static int ThreadGetOption(Tcl_Interp *interp, Tcl_ThreadId id, char *option, Tcl_DString *ds); static int ThreadSetOption(Tcl_Interp *interp, Tcl_ThreadId id, char *option, char *value); static int ThreadReserve(Tcl_Interp *interp, Tcl_ThreadId id, int operation, int wait); static int ThreadEventProc(Tcl_Event *evPtr, int mask); static int ThreadWait(Tcl_Interp *interp); static int ThreadExists(Tcl_ThreadId id); static int ThreadList(Tcl_Interp *interp, Tcl_ThreadId **thrIdArray); static void ThreadErrorProc(Tcl_Interp *interp); static void ThreadFreeProc(void *clientData); static void ThreadExitProc(void *clientData); static void ThreadFreeError(void *clientData); static void ListRemove(ThreadSpecificData *tsdPtr); static void ListRemoveInner(ThreadSpecificData *tsdPtr); static void ListUpdate(ThreadSpecificData *tsdPtr); static void ListUpdateInner(ThreadSpecificData *tsdPtr); static int ThreadJoin(Tcl_Interp *interp, Tcl_ThreadId id); static int ThreadTransfer(Tcl_Interp *interp, Tcl_ThreadId id, Tcl_Channel chan); static int ThreadDetach(Tcl_Interp *interp, Tcl_Channel chan); static int ThreadAttach(Tcl_Interp *interp, char *chanName); static int TransferEventProc(Tcl_Event *evPtr, int mask); static void ThreadGetHandle(Tcl_ThreadId, char *handlePtr); static int ThreadGetId(Tcl_Interp *interp, Tcl_Obj *handleObj, Tcl_ThreadId *thrIdPtr); static void ErrorNoSuchThread(Tcl_Interp *interp, Tcl_ThreadId thrId); static void ThreadCutChannel(Tcl_Interp *interp, Tcl_Channel channel); static int ThreadCancel(Tcl_Interp *interp, Tcl_ThreadId thrId, const char *result, int flags); /* * Functions implementing Tcl commands */ static Tcl_ObjCmdProc2 ThreadCreateObjCmd; static Tcl_ObjCmdProc2 ThreadReserveObjCmd; static Tcl_ObjCmdProc2 ThreadReleaseObjCmd; static Tcl_ObjCmdProc2 ThreadSendObjCmd; static Tcl_ObjCmdProc2 ThreadBroadcastObjCmd; static Tcl_ObjCmdProc2 ThreadUnwindObjCmd; static Tcl_ObjCmdProc2 ThreadExitObjCmd; static Tcl_ObjCmdProc2 ThreadIdObjCmd; static Tcl_ObjCmdProc2 ThreadNamesObjCmd; static Tcl_ObjCmdProc2 ThreadWaitObjCmd; static Tcl_ObjCmdProc2 ThreadExistsObjCmd; static Tcl_ObjCmdProc2 ThreadConfigureObjCmd; static Tcl_ObjCmdProc2 ThreadErrorProcObjCmd; static Tcl_ObjCmdProc2 ThreadJoinObjCmd; static Tcl_ObjCmdProc2 ThreadTransferObjCmd; static Tcl_ObjCmdProc2 ThreadDetachObjCmd; static Tcl_ObjCmdProc2 ThreadAttachObjCmd; static Tcl_ObjCmdProc2 ThreadCancelObjCmd; #ifndef STRINGIFY # define STRINGIFY(x) STRINGIFY1(x) # define STRINGIFY1(x) #x #endif static const char * ThreadInit( Tcl_Interp *interp /* The current Tcl interpreter */ ) { /* Tcl 8.7 interps are only supported on 32-bit machines. * Lower than that is never supported. Bye! */ #if defined(TCL_WIDE_INT_IS_LONG) && TCL_MAJOR_VERSION < 9 # error "Thread 3.0 is only supported with Tcl 9.0 and higher." # error "Please use Thread 2.8 (branch thread-2-8-branch)" #endif /* Even though it's not supported, Thread 3.0 works with Tcl 8.7 * on 32-bit platforms, so allow that for now. It could be that * Tcl 9.0 introduces a further binary incompatibility in the * future, so this is not guaranteed to stay like it is now! */ const char *ver = (sizeof(size_t) == sizeof(int))? "8.7-": "9.0"; if (!((Tcl_InitStubs)(interp, ver, (TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), TCL_STUB_MAGIC))) { return NULL; } if (threadMutex == NULL){ Tcl_MutexLock(&threadMutex); if (threadMutex == NULL){ /* If threadMutex==NULL here, it means that Tcl_MutexLock() is * a dummy function, which is the case in unthreaded Tcl */ const char *msg = "Tcl core wasn't compiled for threading"; Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE)); return NULL; } Tcl_MutexUnlock(&threadMutex); } TCL_CMD(interp, THREAD_CMD_PREFIX"create", ThreadCreateObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"send", ThreadSendObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"broadcast", ThreadBroadcastObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"exit", ThreadExitObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"unwind", ThreadUnwindObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"id", ThreadIdObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"names", ThreadNamesObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"exists", ThreadExistsObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"wait", ThreadWaitObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"configure", ThreadConfigureObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"errorproc", ThreadErrorProcObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"preserve", ThreadReserveObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"release", ThreadReleaseObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"join", ThreadJoinObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"transfer", ThreadTransferObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"detach", ThreadDetachObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"attach", ThreadAttachObjCmd); TCL_CMD(interp, THREAD_CMD_PREFIX"cancel", ThreadCancelObjCmd); /* * Add shared variable commands */ SvInit(interp); /* * Add commands to access thread * synchronization primitives. */ SpInit(interp); /* * Add threadpool commands. */ TpoolInit(interp); return PACKAGE_VERSION "+" STRINGIFY(THREAD_VERSION_UUID) #if defined(__clang__) && defined(__clang_major__) ".clang-" STRINGIFY(__clang_major__) #if __clang_minor__ < 10 "0" #endif STRINGIFY(__clang_minor__) #endif #if defined(__cplusplus) && !defined(__OBJC__) ".cplusplus" #endif #ifndef NDEBUG ".debug" #endif #if !defined(__clang__) && !defined(__INTEL_COMPILER) && defined(__GNUC__) ".gcc-" STRINGIFY(__GNUC__) #if __GNUC_MINOR__ < 10 "0" #endif STRINGIFY(__GNUC_MINOR__) #endif #ifdef __INTEL_COMPILER ".icc-" STRINGIFY(__INTEL_COMPILER) #endif #ifdef HAVE_GDBM ".gdbm" #endif #ifdef HAVE_LMDB ".lmdb" #endif #ifdef TCL_MEM_DEBUG ".memdebug" #endif #if defined(_MSC_VER) ".msvc-" STRINGIFY(_MSC_VER) #endif #ifdef USE_NMAKE ".nmake" #endif #ifndef TCL_CFG_OPTIMIZED ".no-optimize" #endif #ifdef __OBJC__ ".objective-c" #if defined(__cplusplus) "plusplus" #endif #endif #ifdef TCL_CFG_PROFILED ".profile" #endif #ifdef PURIFY ".purify" #endif #ifdef STATIC_BUILD ".static" #endif ; } /* *---------------------------------------------------------------------- * * Thread_Init -- * * Initialize the thread commands. * * Results: * TCL_OK if the package was properly initialized. * * Side effects: * Adds package commands to the current interp. * *---------------------------------------------------------------------- */ DLLEXPORT int Thread_Init( Tcl_Interp *interp /* The current Tcl interpreter */ ) { const char *version = ThreadInit(interp); Tcl_CmdInfo info; if (version == NULL) { return TCL_ERROR; } if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { #if TCL_MAJOR_VERSION > 8 if (info.isNativeObjectProc == 2) { Tcl_CreateObjCommand2(interp, "::thread::build-info", info.objProc2, (void *)version, NULL); } else #endif Tcl_CreateObjCommand(interp, "::thread::build-info", info.objProc, (void *)version, NULL); } Tcl_PkgProvideEx(interp, "Thread", PACKAGE_VERSION, NULL); return Tcl_PkgProvideEx(interp, "thread", PACKAGE_VERSION, NULL); } /* *---------------------------------------------------------------------- * * Init -- * * Make sure internal list of threads references the current thread. * * Results: * None * * Side effects: * The list of threads is initialized to include the current thread. * *---------------------------------------------------------------------- */ static void Init( Tcl_Interp *interp /* Current interpreter. */ ) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->interp == NULL) { Tcl_Interp *tmpInterp, *mainInterp = interp; memset(tsdPtr, 0, sizeof(ThreadSpecificData)); /* * Retrieve main interpreter of the thread, only * main interpreter used as default thread-interpreter, * so no childs here, see bug [d4ba38d00d06ebba] */ while (mainInterp && (tmpInterp = Tcl_GetMaster(mainInterp))) { mainInterp = tmpInterp; } tsdPtr->interp = mainInterp; ListUpdate(tsdPtr); Tcl_CreateThreadExitHandler(ThreadExitProc, threadEmptyResult); } } /* *---------------------------------------------------------------------- * * ThreadCreateObjCmd -- * * This procedure is invoked to process the "thread::create" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadCreateObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_Size argc; int rsrv = 0; const char *arg, *script; int flags = TCL_THREAD_NOFLAGS; Init(interp); /* * Syntax: thread::create ?-joinable? ?-preserved? ?script? */ script = THREAD_CMD_PREFIX"wait"; for (argc = 1; argc < objc; argc++) { arg = Tcl_GetString(objv[argc]); if (OPT_CMP(arg, "--")) { argc++; if ((argc + 1) == objc) { script = Tcl_GetString(objv[argc]); } else { goto usage; } break; } else if (OPT_CMP(arg, "-joinable")) { flags |= TCL_THREAD_JOINABLE; } else if (OPT_CMP(arg, "-preserved")) { rsrv = 1; } else if ((argc + 1) == objc) { script = Tcl_GetString(objv[argc]); } else { goto usage; } } return ThreadCreate(interp, script, TCL_THREAD_STACK_DEFAULT, flags, rsrv); usage: Tcl_WrongNumArgs(interp, 1, objv, "?-joinable? ?script?"); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * ThreadReserveObjCmd -- * * This procedure is invoked to process the "thread::preserve" and * "thread::release" Tcl commands. See the user documentation for * details on it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadReserveObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_ThreadId thrId = NULL; Init(interp); if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?threadId?"); return TCL_ERROR; } if (objc == 2) { if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) { return TCL_ERROR; } } return ThreadReserve(interp, thrId, THREAD_RESERVE, 0); } /* *---------------------------------------------------------------------- * * ThreadReleaseObjCmd -- * * This procedure is invoked to process the "thread::release" Tcl * command. See the user documentation for details on what this * command does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadReleaseObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { int wait = 0; Tcl_ThreadId thrId = NULL; Init(interp); if (objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?-wait? ?threadId?"); return TCL_ERROR; } if (objc > 1) { if (OPT_CMP(Tcl_GetString(objv[1]), "-wait")) { wait = 1; if (objc > 2) { if (ThreadGetId(interp, objv[2], &thrId) != TCL_OK) { return TCL_ERROR; } } } else if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) { return TCL_ERROR; } } return ThreadReserve(interp, thrId, THREAD_RELEASE, wait); } /* *---------------------------------------------------------------------- * * ThreadUnwindObjCmd -- * * This procedure is invoked to process the "thread::unwind" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadUnwindObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Init(interp); if (objc > 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } return ThreadReserve(interp, 0, THREAD_RELEASE, 0); } /* *---------------------------------------------------------------------- * * ThreadExitObjCmd -- * * This procedure is invoked to process the "thread::exit" Tcl * command. This causes an unconditional close of the thread * and is GUARANTEED to cause memory leaks. Use this with caution. * * Results: * Doesn't actually return. * * Side effects: * Lots. improper clean up of resources. * *---------------------------------------------------------------------- */ static int ThreadExitObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { int status = 666; Init(interp); if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?status?"); return TCL_ERROR; } if (objc == 2) { if (Tcl_GetIntFromObj(interp, objv[1], &status) != TCL_OK) { return TCL_ERROR; } } ListRemove(NULL); Tcl_ExitThread(status); return TCL_OK; /* NOT REACHED */ } /* *---------------------------------------------------------------------- * * ThreadIdObjCmd -- * * This procedure is invoked to process the "thread::id" Tcl command. * This returns the ID of the current thread. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ThreadIdObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { char thrHandle[THREAD_HNDLMAXLEN]; Init(interp); if (objc > 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } ThreadGetHandle(Tcl_GetCurrentThread(), thrHandle); Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, TCL_INDEX_NONE)); return TCL_OK; } /* *---------------------------------------------------------------------- * * ThreadNamesObjCmd -- * * This procedure is invoked to process the "thread::names" Tcl * command. This returns a list of all known thread IDs. * These are only threads created via this module (e.g., not * driver threads or the notifier). * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ThreadNamesObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_Size ii, length; char *result, thrHandle[THREAD_HNDLMAXLEN]; Tcl_ThreadId *thrIdArray; Tcl_DString threadNames; Init(interp); if (objc > 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } length = ThreadList(interp, &thrIdArray); if (length == 0) { return TCL_OK; } Tcl_DStringInit(&threadNames); for (ii = 0; ii < length; ii++) { ThreadGetHandle(thrIdArray[ii], thrHandle); Tcl_DStringAppendElement(&threadNames, thrHandle); } length = Tcl_DStringLength(&threadNames); result = Tcl_DStringValue(&threadNames); Tcl_SetObjResult(interp, Tcl_NewStringObj(result, length)); Tcl_DStringFree(&threadNames); Tcl_Free(thrIdArray); return TCL_OK; } /* *---------------------------------------------------------------------- * * ThreadSendObjCmd -- * * This procedure is invoked to process the "thread::send" Tcl * command. This sends a script to another thread for execution. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void threadSendFree(void *ptr) { Tcl_Free(ptr); } static void threadSendObjFree(void *ptr) { Tcl_DecrRefCount((Tcl_Obj *)ptr); } static int ThreadSendObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_Size size, ii = 0; int cmd = 0, ret, flags = 0; Tcl_ThreadId thrId; const char *script, *arg; Tcl_Obj *var = NULL; ThreadClbkData *clbkPtr = NULL; ThreadSendData *sendPtr = NULL; Init(interp); /* * Syntax: thread::send ?-async? ?-head? threadId script ?varName? */ if (objc < 3 || objc > 6) { goto usage; } flags = THREAD_SEND_WAIT; for (ii = 1; ii < objc; ii++) { arg = Tcl_GetString(objv[ii]); if (OPT_CMP(arg, "-async")) { flags &= ~THREAD_SEND_WAIT; } else if (OPT_CMP(arg, "-head")) { flags |= THREAD_SEND_HEAD; } else if (OPT_CMP(arg, "-command")) { flags &= ~THREAD_SEND_WAIT; cmd = 1; } else { break; } } if (ii >= objc) { goto usage; } if (ThreadGetId(interp, objv[ii], &thrId) != TCL_OK) { return TCL_ERROR; } if (++ii >= objc) { goto usage; } script = Tcl_GetStringFromObj(objv[ii], &size); size++; if (++ii < objc) { var = objv[ii]; } if (var && (flags & THREAD_SEND_WAIT) == 0) { if (thrId == Tcl_GetCurrentThread()) { /* * FIXME: Do something for callbacks to self */ Tcl_SetObjResult(interp, Tcl_NewStringObj("can't notify self", TCL_INDEX_NONE)); return TCL_ERROR; } /* * Prepare record for the callback. This is asynchronously * posted back to us when the target thread finishes processing. * We should do a vwait on the "var" to get notified. */ clbkPtr = (ThreadClbkData *)Tcl_Alloc(sizeof(ThreadClbkData)); if (cmd) { clbkPtr->execProc = ThreadClbkCommand; } else { clbkPtr->execProc = ThreadClbkSetVar; } clbkPtr->freeProc = threadSendObjFree; clbkPtr->interp = interp; clbkPtr->threadId = Tcl_GetCurrentThread(); clbkPtr->clientData = Sv_DuplicateObj(var); Tcl_IncrRefCount((Tcl_Obj *)clbkPtr->clientData); } /* * Prepare job record for the target thread */ sendPtr = (ThreadSendData *)Tcl_Alloc(sizeof(ThreadSendData)); sendPtr->interp = NULL; /* Signal to use thread main interp */ sendPtr->execProc = ThreadSendEval; sendPtr->freeProc = threadSendFree; sendPtr->clientData = memcpy(Tcl_Alloc(size), script, (size_t)size); ret = ThreadSend(interp, thrId, sendPtr, clbkPtr, flags); if (var && (flags & THREAD_SEND_WAIT)) { /* * Leave job's result in passed variable * and return the code, like "catch" does. */ Tcl_Obj *resultObj = Tcl_GetObjResult(interp); if (!Tcl_ObjSetVar2(interp, var, NULL, resultObj, TCL_LEAVE_ERR_MSG)) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(ret)); return TCL_OK; } return ret; usage: Tcl_WrongNumArgs(interp,1,objv,"?-async? ?-head? id script ?varName?"); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * ThreadBroadcastObjCmd -- * * This procedure is invoked to process the "thread::broadcast" Tcl * command. This asynchronously sends a script to all known threads. * * Results: * A standard Tcl result. * * Side effects: * Script is sent to all known threads except the caller thread. * *---------------------------------------------------------------------- */ static int ThreadBroadcastObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { int ii, nthreads; Tcl_Size size; const char *script; Tcl_ThreadId *thrIdArray; ThreadSendData *sendPtr, job; Init(interp); if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "script"); return TCL_ERROR; } script = Tcl_GetStringFromObj(objv[1], &size); ++size; /* * Get the list of known threads. Note that this one may * actually change (thread may exit or otherwise cease to * exist) while we circle in the loop below. We really do * not care about that here since we don't return any * script results to the caller. */ nthreads = ThreadList(interp, &thrIdArray); if (nthreads == 0) { return TCL_OK; } /* * Prepare the structure with the job description * to be sent asynchronously to each known thread. */ job.interp = NULL; /* Signal to use thread's main interp */ job.execProc = ThreadSendEval; job.freeProc = threadSendFree; job.clientData = NULL; /* * Now, circle this list and send each thread the script. * This is sent asynchronously, since we do not care what * are they going to do with it. Also, the event is queued * to the head of the event queue (as out-of-band message). */ for (ii = 0; ii < nthreads; ii++) { if (thrIdArray[ii] == Tcl_GetCurrentThread()) { continue; /* Do not broadcast self */ } sendPtr = (ThreadSendData *)Tcl_Alloc(sizeof(ThreadSendData)); *sendPtr = job; sendPtr->clientData = memcpy(Tcl_Alloc(size), script, (size_t)size); ThreadSend(interp, thrIdArray[ii], sendPtr, NULL, THREAD_SEND_HEAD); } Tcl_Free(thrIdArray); Tcl_ResetResult(interp); return TCL_OK; } /* *---------------------------------------------------------------------- * * ThreadWaitObjCmd -- * * This procedure is invoked to process the "thread::wait" Tcl * command. This enters the event loop. * * Results: * Standard Tcl result. * * Side effects: * Enters the event loop. * *---------------------------------------------------------------------- */ static int ThreadWaitObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Init(interp); if (objc > 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } return ThreadWait(interp); } /* *---------------------------------------------------------------------- * * ThreadErrorProcObjCmd -- * * This procedure is invoked to process the "thread::errorproc" * command. This registers a procedure to handle thread errors. * Empty string as the name of the procedure will reset the * default behaviour, which is writing to standard error channel. * * Results: * A standard Tcl result. * * Side effects: * Registers an errorproc. * *---------------------------------------------------------------------- */ static int ThreadErrorProcObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_Size len; char *proc; Init(interp); if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?proc?"); return TCL_ERROR; } Tcl_MutexLock(&threadMutex); if (objc == 1) { if (errorProcString) { Tcl_SetObjResult(interp, Tcl_NewStringObj(errorProcString, TCL_INDEX_NONE)); } } else { if (errorProcString) { Tcl_Free(errorProcString); } proc = Tcl_GetStringFromObj(objv[1], &len); if (len == 0) { errorThreadId = NULL; errorProcString = NULL; } else { errorThreadId = Tcl_GetCurrentThread(); errorProcString = (char *)Tcl_Alloc(1+strlen(proc)); strcpy(errorProcString, proc); Tcl_DeleteThreadExitHandler(ThreadFreeError, NULL); Tcl_CreateThreadExitHandler(ThreadFreeError, NULL); } } Tcl_MutexUnlock(&threadMutex); return TCL_OK; } static void ThreadFreeError( TCL_UNUSED(void *) ) { Tcl_MutexLock(&threadMutex); if (errorThreadId != Tcl_GetCurrentThread()) { Tcl_MutexUnlock(&threadMutex); return; } Tcl_Free(errorProcString); errorThreadId = NULL; errorProcString = NULL; Tcl_MutexUnlock(&threadMutex); } /* *---------------------------------------------------------------------- * * ThreadJoinObjCmd -- * * This procedure is invoked to process the "thread::join" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadJoinObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_ThreadId thrId; Init(interp); /* * Syntax of 'join': id */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "id"); return TCL_ERROR; } if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) { return TCL_ERROR; } return ThreadJoin(interp, thrId); } /* *---------------------------------------------------------------------- * * ThreadTransferObjCmd -- * * This procedure is invoked to process the "thread::transfer" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadTransferObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_ThreadId thrId; Tcl_Channel chan; Init(interp); /* * Syntax of 'transfer': id channel */ if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "id channel"); return TCL_ERROR; } if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) { return TCL_ERROR; } chan = Tcl_GetChannel(interp, Tcl_GetString(objv[2]), NULL); if (chan == NULL) { return TCL_ERROR; } return ThreadTransfer(interp, thrId, Tcl_GetTopChannel(chan)); } /* *---------------------------------------------------------------------- * * ThreadDetachObjCmd -- * * This procedure is invoked to process the "thread::detach" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadDetachObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_Channel chan; Init(interp); /* * Syntax: thread::detach channel */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channel"); return TCL_ERROR; } chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); if (chan == NULL) { return TCL_ERROR; } return ThreadDetach(interp, Tcl_GetTopChannel(chan)); } /* *---------------------------------------------------------------------- * * ThreadAttachObjCmd -- * * This procedure is invoked to process the "thread::attach" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadAttachObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { char *chanName; Init(interp); /* * Syntax: thread::attach channel */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channel"); return TCL_ERROR; } chanName = Tcl_GetString(objv[1]); if (Tcl_IsChannelExisting(chanName)) { return TCL_OK; } return ThreadAttach(interp, chanName); } /* *---------------------------------------------------------------------- * * ThreadExistsObjCmd -- * * This procedure is invoked to process the "thread::exists" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadExistsObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_ThreadId thrId; Init(interp); if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "id"); return TCL_ERROR; } if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) { return TCL_ERROR; } Tcl_SetIntObj(Tcl_GetObjResult(interp), ThreadExists(thrId)!=0); return TCL_OK; } /* *---------------------------------------------------------------------- * * ThreadConfigureObjCmd -- * * This procedure is invoked to process the Tcl "thread::configure" * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * None. *---------------------------------------------------------------------- */ static int ThreadConfigureObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { char *option, *value; Tcl_ThreadId thrId; /* Id of the thread to configure */ int i; /* Iterate over arg-value pairs. */ Tcl_DString ds; /* DString to hold result of * calling GetThreadOption. */ if (objc < 2 || (objc % 2 == 1 && objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "threadlId ?optionName? " "?value? ?optionName value?..."); return TCL_ERROR; } Init(interp); if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) { return TCL_ERROR; } if (objc == 2) { Tcl_DStringInit(&ds); if (ThreadGetOption(interp, thrId, NULL, &ds) != TCL_OK) { Tcl_DStringFree(&ds); return TCL_ERROR; } Tcl_DStringResult(interp, &ds); return TCL_OK; } if (objc == 3) { Tcl_DStringInit(&ds); option = Tcl_GetString(objv[2]); if (ThreadGetOption(interp, thrId, option, &ds) != TCL_OK) { Tcl_DStringFree(&ds); return TCL_ERROR; } Tcl_DStringResult(interp, &ds); return TCL_OK; } for (i = 3; i < objc; i += 2) { option = Tcl_GetString(objv[i-1]); value = Tcl_GetString(objv[i]); if (ThreadSetOption(interp, thrId, option, value) != TCL_OK) { return TCL_ERROR; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * ThreadCancelObjCmd -- * * This procedure is invoked to process the "thread::cancel" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadCancelObjCmd( TCL_UNUSED(void *), /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[] /* Argument objects. */ ) { Tcl_ThreadId thrId; int ii, flags; const char *result; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "?-unwind? id ?result?"); return TCL_ERROR; } flags = 0; ii = 1; if ((objc == 3) || (objc == 4)) { if (OPT_CMP(Tcl_GetString(objv[ii]), "-unwind")) { flags |= TCL_CANCEL_UNWIND; ii++; } } if (ThreadGetId(interp, objv[ii], &thrId) != TCL_OK) { return TCL_ERROR; } ii++; if (ii < objc) { result = Tcl_GetString(objv[ii]); } else { result = NULL; } return ThreadCancel(interp, thrId, result, flags); } /* *---------------------------------------------------------------------- * * ThreadSendEval -- * * Evaluates Tcl script passed from source to target thread. * * Results: * A standard Tcl result. * * Side effects: * *---------------------------------------------------------------------- */ static int ThreadSendEval( Tcl_Interp *interp, void *clientData ) { ThreadSendData *sendPtr = (ThreadSendData *)clientData; char *script = (char*)sendPtr->clientData; return Tcl_EvalEx(interp, script, TCL_INDEX_NONE, TCL_EVAL_GLOBAL); } /* *---------------------------------------------------------------------- * * ThreadClbkSetVar -- * * Sets the Tcl variable in the source thread, as the result * of the asynchronous callback. * * Results: * A standard Tcl result. * * Side effects: * New Tcl variable may be created * *---------------------------------------------------------------------- */ static int ThreadClbkSetVar( Tcl_Interp *interp, void *clientData ) { ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData; Tcl_Obj *var = (Tcl_Obj *)clbkPtr->clientData; Tcl_Obj *valObj; ThreadEventResult *resultPtr = &clbkPtr->result; int rc = TCL_OK; /* * Get the result of the posted command. * We will use it to fill-in the result variable. */ valObj = Tcl_NewStringObj(resultPtr->result, -1); Tcl_IncrRefCount(valObj); if (resultPtr->result != threadEmptyResult) { Tcl_Free(resultPtr->result); } /* * Set the result variable */ if (Tcl_ObjSetVar2(interp, var, NULL, valObj, TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) { rc = TCL_ERROR; goto cleanup; } /* * In case of error, trigger the bgerror mechansim */ if (resultPtr->code == TCL_ERROR) { if (resultPtr->errorCode) { Tcl_SetVar2Ex(interp, "errorCode", NULL, Tcl_NewStringObj(resultPtr->errorCode, TCL_INDEX_NONE), TCL_GLOBAL_ONLY); Tcl_Free(resultPtr->errorCode); } if (resultPtr->errorInfo) { Tcl_SetVar2Ex(interp, "errorInfo", NULL, Tcl_NewStringObj(resultPtr->errorInfo, TCL_INDEX_NONE), TCL_GLOBAL_ONLY); Tcl_Free(resultPtr->errorInfo); } Tcl_SetObjResult(interp, valObj); Tcl_BackgroundException(interp, TCL_ERROR); return TCL_ERROR; } return TCL_OK; cleanup: Tcl_DecrRefCount(valObj); return rc; } static int ThreadClbkCommand(Tcl_Interp *interp, void *clientData) { int status = TCL_OK; ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData; Tcl_Obj *script = (Tcl_Obj *)clbkPtr->clientData; ThreadEventResult *resultPtr = &clbkPtr->result; if (resultPtr->code == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_NewStringObj(resultPtr->result, TCL_INDEX_NONE)); Tcl_BackgroundError(interp); goto cleanup; } if ((status = Tcl_ListObjAppendElement( interp, script, Tcl_NewStringObj(resultPtr->result, TCL_INDEX_NONE))) != TCL_OK) { goto cleanup; } status = Tcl_GlobalEvalObj(interp, script); cleanup: Tcl_Free(resultPtr->result); return status; } /* *---------------------------------------------------------------------- * * ThreadCreate -- * * This procedure is invoked to create a thread containing an * interp to run a script. This returns after the thread has * started executing. * * Results: * A standard Tcl result, which is the thread ID. * * Side effects: * Create a thread. * *---------------------------------------------------------------------- */ static int ThreadCreate( Tcl_Interp *interp, /* Current interpreter. */ const char *script, /* Script to evaluate */ TCL_HASH_TYPE stacksize, /* Zero for default size */ int flags, /* Zero for no flags */ int preserve /* If true, reserve the thread */ ) { char thrHandle[THREAD_HNDLMAXLEN]; ThreadCtrl ctrl; Tcl_ThreadId thrId; ctrl.cd = Tcl_GetAssocData(interp, "thread:nsd", NULL); ctrl.script = (char *)script; ctrl.condWait = NULL; ctrl.flags = 0; Tcl_MutexLock(&threadMutex); if (Tcl_CreateThread(&thrId, NewThread, &ctrl, stacksize, flags) != TCL_OK) { Tcl_MutexUnlock(&threadMutex); Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create a new thread", TCL_INDEX_NONE)); return TCL_ERROR; } /* * Wait for the thread to start because it is using * the ThreadCtrl argument which is on our stack. */ while (ctrl.script != NULL) { Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL); } if (preserve) { ThreadSpecificData *tsdPtr = ThreadExistsInner(thrId); if (tsdPtr == NULL) { Tcl_MutexUnlock(&threadMutex); Tcl_ConditionFinalize(&ctrl.condWait); ErrorNoSuchThread(interp, thrId); return TCL_ERROR; } tsdPtr->refCount++; } Tcl_MutexUnlock(&threadMutex); Tcl_ConditionFinalize(&ctrl.condWait); ThreadGetHandle(thrId, thrHandle); Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, TCL_INDEX_NONE)); return TCL_OK; } /* *---------------------------------------------------------------------- * * NewThread -- * * This routine is the "main()" for a new thread whose task is to * execute a single TCL script. The argument to this function is * a pointer to a structure that contains the text of the Tcl script * to be executed, plus some synchronization primitives. Those are * used so the caller gets signalized when the new thread has * done its initialization. * * Space to hold the ThreadControl structure itself is reserved on * the stack of the calling function. The two condition variables * in the ThreadControl structure are destroyed by the calling * function as well. The calling function will destroy the * ThreadControl structure and the condition variable as soon as * ctrlPtr->condWait is signaled, so this routine must make copies * of any data it might need after that point. * * Results: * none * * Side effects: * A Tcl script is executed in a new thread. * *---------------------------------------------------------------------- */ Tcl_ThreadCreateType NewThread( void *clientData ) { ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_Interp *interp; int result = TCL_OK; size_t scriptLen; char *evalScript; /* * Initialize the interpreter. The bad thing here is that we * assume that initialization of the Tcl interp will be * error free, which it may not. In the future we must recover * from this and exit gracefully (this is not that easy as * it seems on the first glance...) */ #ifdef NS_AOLSERVER NsThreadInterpData *md = (NsThreadInterpData *)ctrlPtr->cd; Ns_ThreadSetName("-tclthread-"); interp = (Tcl_Interp*)Ns_TclAllocateInterp(md ? md->server : NULL); #else interp = Tcl_CreateInterp(); result = Tcl_Init(interp); #endif #if !defined(NS_AOLSERVER) || (defined(NS_MAJOR_VERSION) && NS_MAJOR_VERSION >= 4) result = Thread_Init(interp); #endif tsdPtr->interp = interp; Tcl_MutexLock(&threadMutex); /* * Update the list of threads. */ ListUpdateInner(tsdPtr); /* * We need to keep a pointer to the alloc'ed mem of the script * we are eval'ing, for the case that we exit during evaluation */ scriptLen = strlen(ctrlPtr->script); evalScript = strcpy((char *)Tcl_Alloc(scriptLen+1), ctrlPtr->script); Tcl_CreateThreadExitHandler(ThreadExitProc, evalScript); /* * Notify the parent we are alive. */ ctrlPtr->script = NULL; Tcl_ConditionNotify(&ctrlPtr->condWait); Tcl_MutexUnlock(&threadMutex); /* * Run the script. */ Tcl_Preserve(tsdPtr->interp); result = Tcl_EvalEx(tsdPtr->interp, evalScript,scriptLen,TCL_EVAL_GLOBAL); if (result != TCL_OK) { ThreadErrorProc(tsdPtr->interp); } /* * Clean up. Note: add something like TlistRemove for the transfer list. */ if (tsdPtr->doOneEvent) { Tcl_ConditionFinalize(&tsdPtr->doOneEvent); } ListRemove(tsdPtr); /* * It is up to all other extensions, including Tk, to be responsible * for their own events when they receive their Tcl_CallWhenDeleted * notice when we delete this interp. */ #ifdef NS_AOLSERVER Ns_TclMarkForDelete(tsdPtr->interp); Ns_TclDeAllocateInterp(tsdPtr->interp); #else Tcl_DeleteInterp(tsdPtr->interp); #endif Tcl_Release(tsdPtr->interp); /*tsdPtr->interp = NULL;*/ /* * Tcl_ExitThread calls Tcl_FinalizeThread() indirectly which calls * ThreadExitHandlers and cleans the notifier as well as other sub- * systems that save thread state data. */ Tcl_ExitThread(result); TCL_THREAD_CREATE_RETURN; } /* *---------------------------------------------------------------------- * * ThreadErrorProc -- * * Send a message to the thread willing to hear about errors. * * Results: * None * * Side effects: * Send an event. * *---------------------------------------------------------------------- */ static void ThreadErrorProc( Tcl_Interp *interp /* Interp that failed */ ) { ThreadSendData *sendPtr; const char *argv[3]; char buf[THREAD_HNDLMAXLEN]; const char *errorInfo; errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); if (errorInfo == NULL) { errorInfo = ""; } if (errorProcString == NULL) { #ifdef NS_AOLSERVER Ns_Log(Error, "%s\n%s", Tcl_GetString(Tcl_GetObjResult(interp)), errorInfo); #else Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel == NULL) { /* Fixes the [#634845] bug; credits to * Wojciech Kocjan */ return; } ThreadGetHandle(Tcl_GetCurrentThread(), buf); Tcl_WriteChars(errChannel, "Error from thread ", TCL_INDEX_NONE); Tcl_WriteChars(errChannel, buf, TCL_INDEX_NONE); Tcl_WriteChars(errChannel, "\n", 1); Tcl_WriteChars(errChannel, errorInfo, TCL_INDEX_NONE); Tcl_WriteChars(errChannel, "\n", 1); #endif } else { ThreadGetHandle(Tcl_GetCurrentThread(), buf); argv[0] = errorProcString; argv[1] = buf; argv[2] = errorInfo; sendPtr = (ThreadSendData *)Tcl_Alloc(sizeof(ThreadSendData)); sendPtr->execProc = ThreadSendEval; sendPtr->freeProc = threadSendFree; sendPtr->clientData = Tcl_Merge(3, argv); sendPtr->interp = NULL; ThreadSend(interp, errorThreadId, sendPtr, NULL, 0); } } /* *---------------------------------------------------------------------- * * ListUpdate -- * * Add the thread local storage to the list. This grabs the * mutex to protect the list. * * Results: * None * * Side effects: * None. * *---------------------------------------------------------------------- */ static void ListUpdate( ThreadSpecificData *tsdPtr ) { if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); } Tcl_MutexLock(&threadMutex); ListUpdateInner(tsdPtr); Tcl_MutexUnlock(&threadMutex); } /* *---------------------------------------------------------------------- * * ListUpdateInner -- * * Add the thread local storage to the list. This assumes the caller * has obtained the threadMutex. * * Results: * None * * Side effects: * Add the thread local storage to its list. * *---------------------------------------------------------------------- */ static void ListUpdateInner( ThreadSpecificData *tsdPtr ) { if (threadList) { threadList->prevPtr = tsdPtr; } tsdPtr->nextPtr = threadList; tsdPtr->prevPtr = NULL; tsdPtr->threadId = Tcl_GetCurrentThread(); threadList = tsdPtr; } /* *---------------------------------------------------------------------- * * ListRemove -- * * Remove the thread local storage from its list. This grabs the * mutex to protect the list. * * Results: * None * * Side effects: * Remove the thread local storage from its list. * *---------------------------------------------------------------------- */ static void ListRemove( ThreadSpecificData *tsdPtr ) { if (tsdPtr == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); } Tcl_MutexLock(&threadMutex); ListRemoveInner(tsdPtr); Tcl_MutexUnlock(&threadMutex); } /* *---------------------------------------------------------------------- * * ListRemoveInner -- * * Remove the thread local storage from its list. * * Results: * None * * Side effects: * Remove the thread local storage from its list. * *---------------------------------------------------------------------- */ static void ListRemoveInner( ThreadSpecificData *tsdPtr ) { if (tsdPtr->prevPtr || tsdPtr->nextPtr) { if (tsdPtr->prevPtr) { tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; } else { threadList = tsdPtr->nextPtr; } if (tsdPtr->nextPtr) { tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; } tsdPtr->nextPtr = NULL; tsdPtr->prevPtr = NULL; } else if (tsdPtr == threadList) { threadList = NULL; } } /* *---------------------------------------------------------------------- * * ThreadList -- * * Return a list of threads running Tcl interpreters. * * Results: * Number of threads. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ThreadList( TCL_UNUSED(Tcl_Interp *), Tcl_ThreadId **thrIdArray ) { int ii, count = 0; ThreadSpecificData *tsdPtr; Tcl_MutexLock(&threadMutex); /* * First walk; find out how many threads are registered. * We may avoid this and gain some speed by maintaining * the counter of allocated structs in the threadList. */ for (tsdPtr = threadList; tsdPtr; tsdPtr = tsdPtr->nextPtr) { count++; } if (count == 0) { Tcl_MutexUnlock(&threadMutex); return 0; } /* * Allocate storage for passing thread id's to caller */ *thrIdArray = (Tcl_ThreadId *)Tcl_Alloc(count * sizeof(Tcl_ThreadId)); /* * Second walk; fill-in the array with thread ID's */ for (tsdPtr = threadList, ii = 0; tsdPtr; tsdPtr = tsdPtr->nextPtr, ii++) { (*thrIdArray)[ii] = tsdPtr->threadId; } Tcl_MutexUnlock(&threadMutex); return count; } /* *---------------------------------------------------------------------- * * ThreadExists -- * * Test whether a thread given by it's id is known to us. * * Results: * Pointer to thread specific data structure or * NULL if no thread with given ID found * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ThreadExists( Tcl_ThreadId thrId ) { ThreadSpecificData *tsdPtr; Tcl_MutexLock(&threadMutex); tsdPtr = ThreadExistsInner(thrId); Tcl_MutexUnlock(&threadMutex); return tsdPtr != NULL; } /* *---------------------------------------------------------------------- * * ThreadExistsInner -- * * Test whether a thread given by it's id is known to us. Assumes * caller holds the thread mutex. * * Results: * Pointer to thread specific data structure or * NULL if no thread with given ID found * * Side effects: * None. * *---------------------------------------------------------------------- */ static ThreadSpecificData * ThreadExistsInner( Tcl_ThreadId thrId /* Thread id to look for. */ ) { ThreadSpecificData *tsdPtr; for (tsdPtr = threadList; tsdPtr; tsdPtr = tsdPtr->nextPtr) { if (tsdPtr->threadId == thrId) { return tsdPtr; } } return NULL; } /* *---------------------------------------------------------------------- * * ThreadCancel -- * * Cancels a script in another thread. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ThreadCancel( Tcl_Interp *interp, /* The current interpreter. */ Tcl_ThreadId thrId, /* Thread ID of other interpreter. */ const char *result, /* The error message or NULL for default. */ int flags /* Flags for Tcl_CancelEval. */ ) { int code; Tcl_Obj *resultObj = NULL; ThreadSpecificData *tsdPtr; /* ... of the target thread */ Tcl_MutexLock(&threadMutex); tsdPtr = ThreadExistsInner(thrId); if (tsdPtr == NULL) { Tcl_MutexUnlock(&threadMutex); ErrorNoSuchThread(interp, thrId); return TCL_ERROR; } if (result != NULL) { resultObj = Tcl_NewStringObj(result, TCL_INDEX_NONE); } code = Tcl_CancelEval(tsdPtr->interp, resultObj, NULL, flags); Tcl_MutexUnlock(&threadMutex); return code; } /* *---------------------------------------------------------------------- * * ThreadJoin -- * * Wait for the exit of a different thread. * * Results: * A standard Tcl result. * * Side effects: * The status of the exiting thread is left in the interp result * area, but only in the case of success. * *---------------------------------------------------------------------- */ static int ThreadJoin( Tcl_Interp *interp, /* The current interpreter. */ Tcl_ThreadId thrId /* Thread ID of other interpreter. */ ) { int ret, state; ret = Tcl_JoinThread(thrId, &state); if (ret == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult (interp), state); } else { char thrHandle[THREAD_HNDLMAXLEN]; ThreadGetHandle(thrId, thrHandle); Tcl_AppendResult(interp, "cannot join thread ", thrHandle, (void *)NULL); } return ret; } /* *---------------------------------------------------------------------- * * ThreadTransfer -- * * Transfers the specified channel which must not be shared and has * to be registered in the given interp from that location to the * main interp of the specified thread. * * Thanks to Anreas Kupries for the initial implementation. * * Results: * A standard Tcl result. * * Side effects: * The thread-global lists of all known channels of both threads * involved (specified and current) are modified. The channel is * moved, all event handling for the channel is killed. * *---------------------------------------------------------------------- */ static int ThreadTransfer( Tcl_Interp *interp, /* The current interpreter. */ Tcl_ThreadId thrId, /* Thread Id of other interpreter. */ Tcl_Channel chan /* The channel to transfer */ ) { /* Steps to perform for the transfer: * * i. Sanity checks: chan has to registered in interp, must not be * shared. This automatically excludes the special channels for * stdin, stdout and stderr! * ii. Clear event handling. * iii. Bump reference counter up to prevent destruction during the * following unregister, then unregister the channel from the * interp. Remove it from the thread-global list of all channels * too. * iv. Wrap the channel into an event and send that to the other * thread, then wait for the other thread to process our message. * v. The event procedure called by the other thread is * 'TransferEventProc'. It links the channel into the * thread-global list of channels for that thread, registers it * in the main interp of the other thread, removes the artificial * reference, at last notifies this thread of the sucessful * transfer. This allows this thread then to proceed. */ TransferEvent *evPtr; TransferResult *resultPtr; if (!Tcl_IsChannelRegistered(interp, chan)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", TCL_INDEX_NONE)); } if (Tcl_IsChannelShared(chan)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", TCL_INDEX_NONE)); return TCL_ERROR; } /* * Short circuit transfers to ourself. Nothing to do. */ if (thrId == Tcl_GetCurrentThread()) { return TCL_OK; } Tcl_MutexLock(&threadMutex); /* * Verify the thread exists. */ if (ThreadExistsInner(thrId) == NULL) { Tcl_MutexUnlock(&threadMutex); ErrorNoSuchThread(interp, thrId); return TCL_ERROR; } /* * Cut the channel out of the interp/thread */ ThreadCutChannel(interp, chan); /* * Wrap it into an event. */ resultPtr = (TransferResult *)Tcl_Alloc(sizeof(TransferResult)); evPtr = (TransferEvent *)Tcl_Alloc(sizeof(TransferEvent)); evPtr->chan = chan; evPtr->event.proc = TransferEventProc; evPtr->resultPtr = resultPtr; /* * Initialize the result fields. */ resultPtr->done = (Tcl_Condition) NULL; resultPtr->resultCode = -1; resultPtr->resultMsg = (char *) NULL; /* * Maintain the cleanup list. */ resultPtr->srcThreadId = Tcl_GetCurrentThread(); resultPtr->dstThreadId = thrId; resultPtr->eventPtr = evPtr; SpliceIn(resultPtr, transferList); /* * Queue the event and poke the other thread's notifier. */ Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY); /* * (*) Block until the other thread has either processed the transfer * or rejected it. */ while (resultPtr->resultCode < 0) { Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); } /* * Unlink result from the result list. */ SpliceOut(resultPtr, transferList); resultPtr->eventPtr = NULL; resultPtr->nextPtr = NULL; resultPtr->prevPtr = NULL; Tcl_MutexUnlock(&threadMutex); Tcl_ConditionFinalize(&resultPtr->done); /* * Process the result now. */ if (resultPtr->resultCode != TCL_OK) { /* * Transfer failed, restore old state of channel with respect * to current thread and specified interp. */ Tcl_SpliceChannel(chan); Tcl_RegisterChannel(interp, chan); Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan); Tcl_AppendResult(interp, "transfer failed: ", (void *)NULL); if (resultPtr->resultMsg) { Tcl_AppendResult(interp, resultPtr->resultMsg, (void *)NULL); Tcl_Free(resultPtr->resultMsg); } else { Tcl_AppendResult(interp, "for reasons unknown", (void *)NULL); } Tcl_Free(resultPtr); return TCL_ERROR; } if (resultPtr->resultMsg) { Tcl_Free(resultPtr->resultMsg); } Tcl_Free(resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * ThreadDetach -- * * Detaches the specified channel which must not be shared and has * to be registered in the given interp. The detached channel is * left in the transfer list until some other thread attaches it + by calling the "thread::attach" command. * * Results: * A standard Tcl result. * * Side effects: * The thread-global lists of all known channels (transferList) * is modified. All event handling for the channel is killed. * *---------------------------------------------------------------------- */ static int ThreadDetach( Tcl_Interp *interp, /* The current interpreter. */ Tcl_Channel chan /* The channel to detach */ ) { TransferEvent *evPtr; TransferResult *resultPtr; if (!Tcl_IsChannelRegistered(interp, chan)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", TCL_INDEX_NONE)); } if (Tcl_IsChannelShared(chan)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", TCL_INDEX_NONE)); return TCL_ERROR; } /* * Cut the channel out of the interp/thread */ ThreadCutChannel(interp, chan); /* * Wrap it into the list of transfered channels. We generate no * events associated with the detached channel, thus really not * needing the transfer event structure allocated here. This * is done purely to avoid having yet another wrapper. */ resultPtr = (TransferResult *)Tcl_Alloc(sizeof(TransferResult)); evPtr = (TransferEvent *)Tcl_Alloc(sizeof(TransferEvent)); evPtr->chan = chan; evPtr->event.proc = NULL; evPtr->resultPtr = resultPtr; /* * Initialize the result fields. This is not used. */ resultPtr->done = NULL; resultPtr->resultCode = -1; resultPtr->resultMsg = NULL; /* * Maintain the cleanup list. By setting the dst/srcThreadId * to zero we signal the code in ThreadAttach that this is the * detached channel. Therefore it should not be mistaken for * some regular TransferChannel operation underway. Also, this * will prevent the code in ThreadExitProc to splice out this * record from the list when the threads are exiting. * A side effect of this is that we may have entries in this * list which may never be removed (i.e. nobody attaches the * channel later on). This will result in both Tcl channel and * memory leak. */ resultPtr->srcThreadId = NULL; resultPtr->dstThreadId = NULL; resultPtr->eventPtr = evPtr; Tcl_MutexLock(&threadMutex); SpliceIn(resultPtr, transferList); Tcl_MutexUnlock(&threadMutex); return TCL_OK; } /* *---------------------------------------------------------------------- * * ThreadAttach -- * * Attaches the previously detached channel into the current * interpreter. * * Results: * A standard Tcl result. * * Side effects: * The thread-global lists of all known channels (transferList) * is modified. * *---------------------------------------------------------------------- */ static int ThreadAttach( Tcl_Interp *interp, /* The current interpreter. */ char *chanName /* The name of the channel to detach */ ) { int found = 0; Tcl_Channel chan = NULL; TransferResult *resPtr; /* * Locate the channel to attach by looking up its name in * the list of transfered channels. Watch that we don't * hit the regular channel transfer event. */ Tcl_MutexLock(&threadMutex); for (resPtr = transferList; resPtr; resPtr = resPtr->nextPtr) { chan = resPtr->eventPtr->chan; if (!strcmp(Tcl_GetChannelName(chan),chanName) && !resPtr->dstThreadId) { if (Tcl_IsChannelExisting(chanName)) { Tcl_MutexUnlock(&threadMutex); Tcl_AppendResult(interp, "channel already exists", (void *)NULL); return TCL_ERROR; } SpliceOut(resPtr, transferList); Tcl_Free(resPtr->eventPtr); Tcl_Free(resPtr); found = 1; break; } } Tcl_MutexUnlock(&threadMutex); if (found == 0) { Tcl_AppendResult(interp, "channel not detached", (void *)NULL); return TCL_ERROR; } /* * Splice channel into the current interpreter */ Tcl_SpliceChannel(chan); Tcl_RegisterChannel(interp, chan); Tcl_UnregisterChannel(NULL, chan); return TCL_OK; } /* *---------------------------------------------------------------------- * * ThreadSend -- * * Run the procedure in other thread. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ThreadSend( Tcl_Interp *interp, /* The current interpreter. */ Tcl_ThreadId thrId, /* Thread Id of other thread. */ ThreadSendData *send, /* Pointer to structure with work to do */ ThreadClbkData *clbk, /* Opt. callback structure (may be NULL) */ int flags /* Wait or queue to tail */ ) { ThreadSpecificData *tsdPtr = NULL; /* ... of the target thread */ int code; ThreadEvent *eventPtr; ThreadEventResult *resultPtr; /* * Verify the thread exists and is not in the error state. * The thread is in the error state only if we've configured * it to unwind on script evaluation error and last script * evaluation resulted in error actually. */ Tcl_MutexLock(&threadMutex); tsdPtr = ThreadExistsInner(thrId); if (tsdPtr == NULL || (tsdPtr->flags & THREAD_FLAGS_INERROR)) { int inerror = tsdPtr && (tsdPtr->flags & THREAD_FLAGS_INERROR); Tcl_MutexUnlock(&threadMutex); ThreadFreeProc(send); if (clbk) { ThreadFreeProc(clbk); } if (inerror) { Tcl_SetObjResult(interp, Tcl_NewStringObj("thread is in error", TCL_INDEX_NONE)); } else { ErrorNoSuchThread(interp, thrId); } return TCL_ERROR; } /* * Short circuit sends to ourself (synchronously only). */ if (thrId == Tcl_GetCurrentThread() && (flags & THREAD_SEND_WAIT)) { Tcl_MutexUnlock(&threadMutex); if (!(flags & THREAD_SEND_HEAD)) { /* * Be sure all already queued events are processed before this event */ while ( Tcl_DoOneEvent((TCL_ALL_EVENTS & ~TCL_IDLE_EVENTS)|TCL_DONT_WAIT) ) {}; } /* call it synchronously right now */ code = (*send->execProc)(interp, send); ThreadFreeProc(send); return code; } /* * Create the event for target thread event queue. */ eventPtr = (ThreadEvent *)Tcl_Alloc(sizeof(ThreadEvent)); eventPtr->sendData = send; eventPtr->clbkData = clbk; /* * Target thread about to service * another event */ if (tsdPtr->maxEventsCount) { tsdPtr->eventsPending++; } /* * Caller wants to be notified, so we must take care * it's interpreter stays alive until we've finished. */ if (eventPtr->clbkData) { Tcl_Preserve(eventPtr->clbkData->interp); } if ((flags & THREAD_SEND_WAIT) == 0) { resultPtr = NULL; eventPtr->resultPtr = NULL; } else { resultPtr = (ThreadEventResult *)Tcl_Alloc(sizeof(ThreadEventResult)); resultPtr->done = NULL; resultPtr->result = NULL; resultPtr->errorCode = NULL; resultPtr->errorInfo = NULL; resultPtr->dstThreadId = thrId; resultPtr->srcThreadId = Tcl_GetCurrentThread(); resultPtr->eventPtr = eventPtr; eventPtr->resultPtr = resultPtr; SpliceIn(resultPtr, resultList); } /* * Queue the event and poke the other thread's notifier. */ eventPtr->event.proc = ThreadEventProc; if ((flags & THREAD_SEND_HEAD)) { Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)eventPtr, TCL_QUEUE_HEAD|TCL_QUEUE_ALERT_IF_EMPTY); } else { Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)eventPtr, TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY); } if ((flags & THREAD_SEND_WAIT) == 0) { /* * Might potentially spend some time here, until the * worker thread cleans up its queue a little bit. */ if ((flags & THREAD_SEND_CLBK) == 0) { while (tsdPtr->maxEventsCount && tsdPtr->eventsPending > tsdPtr->maxEventsCount) { Tcl_ConditionWait(&tsdPtr->doOneEvent, &threadMutex, NULL); } } Tcl_MutexUnlock(&threadMutex); return TCL_OK; } /* * Block on the result indefinitely. */ Tcl_ResetResult(interp); while (resultPtr->result == NULL) { Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); } SpliceOut(resultPtr, resultList); Tcl_MutexUnlock(&threadMutex); /* * Return result to caller */ if (resultPtr->code == TCL_ERROR) { if (resultPtr->errorCode) { Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL); Tcl_Free(resultPtr->errorCode); } if (resultPtr->errorInfo) { Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(resultPtr->errorInfo, TCL_INDEX_NONE)); Tcl_Free(resultPtr->errorInfo); } } code = resultPtr->code; Tcl_SetObjResult(interp, Tcl_NewStringObj(resultPtr->result, -1)); /* * Cleanup */ Tcl_ConditionFinalize(&resultPtr->done); if (resultPtr->result != threadEmptyResult) { Tcl_Free(resultPtr->result); } Tcl_Free(resultPtr); return code; } /* *---------------------------------------------------------------------- * * ThreadWait -- * * Waits for events and process them as they come, until signaled * to stop. * * Results: * Standard Tcl result. * * Side effects: * Deletes any thread::send or thread::transfer events that are * pending. * *---------------------------------------------------------------------- */ static int ThreadWait(Tcl_Interp *interp) { int code = TCL_OK; int canrun = 1; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Process events until signaled to stop. */ while (canrun) { /* * About to service another event. * Wake-up eventual sleepers. */ if (tsdPtr->maxEventsCount) { Tcl_MutexLock(&threadMutex); tsdPtr->eventsPending--; Tcl_ConditionNotify(&tsdPtr->doOneEvent); Tcl_MutexUnlock(&threadMutex); } /* * Attempt to process one event, blocking forever until an * event is actually received. The event processed may cause * a script in progress to be canceled or exceed its limit; * therefore, check for these conditions if we are able to * (i.e. we are running in a high enough version of Tcl). */ Tcl_DoOneEvent(TCL_ALL_EVENTS); /* * If the script has been unwound, bail out immediately. This does * not follow the recommended guidelines for how extensions should * handle the script cancellation functionality because this is * not a "normal" extension. Most extensions do not have a command * that simply enters an infinite Tcl event loop. Normal extensions * should not specify the TCL_CANCEL_UNWIND when calling the * Tcl_Canceled function to check if the command has been canceled. */ if (Tcl_Canceled(tsdPtr->interp, TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) { code = TCL_ERROR; break; } if (Tcl_LimitExceeded(tsdPtr->interp)) { code = TCL_ERROR; break; } /* * Test stop condition under mutex since * some other thread may flip our flags. */ Tcl_MutexLock(&threadMutex); canrun = (tsdPtr->flags & THREAD_FLAGS_STOPPED) == 0; Tcl_MutexUnlock(&threadMutex); } /* * If the event processing loop above was terminated due to a * script in progress being canceled or exceeding its limits, * transfer the error to the current interpreter. */ if (code != TCL_OK) { char buf[THREAD_HNDLMAXLEN]; const char *errorInfo; errorInfo = Tcl_GetVar2(tsdPtr->interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); if (errorInfo == NULL) { errorInfo = Tcl_GetString(Tcl_GetObjResult(tsdPtr->interp)); } ThreadGetHandle(Tcl_GetCurrentThread(), buf); Tcl_AppendResult(interp, "Error from thread ", buf, "\n", errorInfo, (void *)NULL); } /* * Remove from the list of active threads, so nobody can post * work to this thread, since it is just about to terminate. */ ListRemove(tsdPtr); /* * Now that the event processor for this thread is closing, * delete all pending thread::send and thread::transfer events. * These events are owned by us. We don't delete anyone else's * events, but ours. */ Tcl_DeleteEvents((Tcl_EventDeleteProc*)ThreadDeleteEvent, NULL); return code; } /* *---------------------------------------------------------------------- * * ThreadReserve -- * * Results: * * Side effects: * *---------------------------------------------------------------------- */ static int ThreadReserve( Tcl_Interp *interp, /* Current interpreter */ Tcl_ThreadId thrId, /* Target thread ID */ int operation, /* THREAD_RESERVE | THREAD_RELEASE */ int wait /* Wait for thread to exit */ ) { int users, dowait = 0; ThreadEvent *evPtr; ThreadSpecificData *tsdPtr; Tcl_MutexLock(&threadMutex); /* * Check the given thread */ if (thrId == NULL) { tsdPtr = TCL_TSD_INIT(&dataKey); } else { tsdPtr = ThreadExistsInner(thrId); if (tsdPtr == NULL) { Tcl_MutexUnlock(&threadMutex); ErrorNoSuchThread(interp, thrId); return TCL_ERROR; } } switch (operation) { case THREAD_RESERVE: ++tsdPtr->refCount; break; case THREAD_RELEASE: --tsdPtr->refCount; dowait = wait; break; } users = tsdPtr->refCount; if (users <= 0) { /* * We're last attached user, so tear down the *target* thread */ tsdPtr->flags |= THREAD_FLAGS_STOPPED; if (thrId && thrId != Tcl_GetCurrentThread() /* Not current! */) { ThreadEventResult *resultPtr = NULL; /* * Remove from the list of active threads, so nobody can post * work to this thread, since it is just about to terminate. */ ListRemoveInner(tsdPtr); /* * Send an dummy event, just to wake-up target thread. * It should immediately exit thereafter. We might get * stuck here for long time if user really wants to * be absolutely sure that the thread has exited. */ if (dowait) { resultPtr = (ThreadEventResult*) Tcl_Alloc(sizeof(ThreadEventResult)); resultPtr->done = NULL; resultPtr->result = NULL; resultPtr->code = TCL_OK; resultPtr->errorCode = NULL; resultPtr->errorInfo = NULL; resultPtr->dstThreadId = thrId; resultPtr->srcThreadId = Tcl_GetCurrentThread(); SpliceIn(resultPtr, resultList); } evPtr = (ThreadEvent *)Tcl_Alloc(sizeof(ThreadEvent)); evPtr->event.proc = ThreadEventProc; evPtr->sendData = NULL; evPtr->clbkData = NULL; evPtr->resultPtr = resultPtr; Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY); if (dowait) { while (resultPtr->result == NULL) { Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); } SpliceOut(resultPtr, resultList); Tcl_ConditionFinalize(&resultPtr->done); if (resultPtr->result != threadEmptyResult) { Tcl_Free(resultPtr->result); /* Will be ignored anyway */ } Tcl_Free(resultPtr); } } } Tcl_MutexUnlock(&threadMutex); Tcl_SetIntObj(Tcl_GetObjResult(interp), (users > 0) ? users : 0); return TCL_OK; } /* *---------------------------------------------------------------------- * * ThreadEventProc -- * * Handle the event in the target thread. * * Results: * Returns 1 to indicate that the event was processed. * * Side effects: * Fills out the ThreadEventResult struct. * *---------------------------------------------------------------------- */ static int ThreadEventProc( Tcl_Event *evPtr, /* Really ThreadEvent */ TCL_UNUSED(int) ) { ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_Interp *interp = NULL; Tcl_ThreadId thrId = Tcl_GetCurrentThread(); ThreadEvent *eventPtr = (ThreadEvent*)evPtr; ThreadSendData *sendPtr = eventPtr->sendData; ThreadClbkData *clbkPtr = eventPtr->clbkData; ThreadEventResult* resultPtr = eventPtr->resultPtr; int code = TCL_ERROR; /* Pessimistic assumption */ /* * See whether user has any preferences about which interpreter * to use for running this job. The job structure might identify * one. If not, just use the thread's main interpreter which is * stored in the thread specific data structure. * Note that later on we might discover that we're running the * async callback script. In this case, interpreter will be * changed to one given in the callback. */ interp = (sendPtr && sendPtr->interp) ? sendPtr->interp : tsdPtr->interp; if (interp != NULL) { Tcl_Preserve(interp); if (clbkPtr && clbkPtr->threadId == thrId) { Tcl_Release(interp); /* Watch: this thread evaluates its own callback. */ interp = clbkPtr->interp; Tcl_Preserve(interp); } Tcl_ResetResult(interp); if (sendPtr) { Tcl_CreateThreadExitHandler(ThreadFreeProc, sendPtr); if (clbkPtr) { Tcl_CreateThreadExitHandler(ThreadFreeProc, clbkPtr); } code = (*sendPtr->execProc)(interp, sendPtr); Tcl_DeleteThreadExitHandler(ThreadFreeProc, sendPtr); if (clbkPtr) { Tcl_DeleteThreadExitHandler(ThreadFreeProc, clbkPtr); } } else { code = TCL_OK; } } if (sendPtr) { ThreadFreeProc(sendPtr); eventPtr->sendData = NULL; } if (resultPtr) { /* * Report job result synchronously to waiting caller */ Tcl_MutexLock(&threadMutex); ThreadSetResult(interp, code, resultPtr); Tcl_ConditionNotify(&resultPtr->done); Tcl_MutexUnlock(&threadMutex); /* * We still need to release the reference to the Tcl * interpreter added by ThreadSend whenever the callback * data is not NULL. */ if (clbkPtr) { Tcl_Release(clbkPtr->interp); } } else if (clbkPtr && clbkPtr->threadId != thrId) { ThreadSendData *tmpPtr = (ThreadSendData*)clbkPtr; /* * Route the callback back to it's originator. * Do not wait for the result. */ if (code != TCL_OK) { ThreadErrorProc(interp); } ThreadSetResult(interp, code, &clbkPtr->result); ThreadSend(interp, clbkPtr->threadId, tmpPtr, NULL, THREAD_SEND_CLBK); } else if (code != TCL_OK) { /* * Only pass errors onto the registered error handler * when we don't have a result target for this event. */ ThreadErrorProc(interp); /* * We still need to release the reference to the Tcl * interpreter added by ThreadSend whenever the callback * data is not NULL. */ if (clbkPtr) { Tcl_Release(clbkPtr->interp); } } else { /* * We still need to release the reference to the Tcl * interpreter added by ThreadSend whenever the callback * data is not NULL. */ if (clbkPtr) { Tcl_Release(clbkPtr->interp); } } if (interp != NULL) { Tcl_Release(interp); } /* * Mark unwind scenario for this thread if the script resulted * in error condition and thread has been marked to unwind. * This will cause thread to disappear from the list of active * threads, clean-up its event queue and exit. */ if (code != TCL_OK) { Tcl_MutexLock(&threadMutex); if (tsdPtr->flags & THREAD_FLAGS_UNWINDONERROR) { tsdPtr->flags |= THREAD_FLAGS_INERROR; if (tsdPtr->refCount == 0) { tsdPtr->flags |= THREAD_FLAGS_STOPPED; } } Tcl_MutexUnlock(&threadMutex); } return 1; } /* *---------------------------------------------------------------------- * * ThreadSetResult -- * * Results: * * Side effects: * *---------------------------------------------------------------------- */ static void ThreadSetResult( Tcl_Interp *interp, int code, ThreadEventResult *resultPtr ) { const char *errorCode, *errorInfo, *result; size_t size; if (interp == NULL) { code = TCL_ERROR; errorInfo = ""; errorCode = "THREAD"; result = "no target interp!"; size = strlen(result); resultPtr->result = (size) ? memcpy(Tcl_Alloc(1+size), result, 1+size) : threadEmptyResult; } else { result = Tcl_GetString(Tcl_GetObjResult(interp)); size = Tcl_GetObjResult(interp)->length; resultPtr->result = (size) ? memcpy(Tcl_Alloc(1+size), result, 1+size) : threadEmptyResult; if (code == TCL_ERROR) { errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY); errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); } else { errorCode = NULL; errorInfo = NULL; } } resultPtr->code = code; if (errorCode != NULL) { size = strlen(errorCode) + 1; resultPtr->errorCode = (char *)memcpy(Tcl_Alloc(size), errorCode, size); } else { resultPtr->errorCode = NULL; } if (errorInfo != NULL) { size = strlen(errorInfo) + 1; resultPtr->errorInfo = (char *)memcpy(Tcl_Alloc(size), errorInfo, size); } else { resultPtr->errorInfo = NULL; } } /* *---------------------------------------------------------------------- * * ThreadGetOption -- * * Results: * * Side effects: * *---------------------------------------------------------------------- */ static int ThreadGetOption( Tcl_Interp *interp, Tcl_ThreadId thrId, char *option, Tcl_DString *dsPtr ) { size_t len; ThreadSpecificData *tsdPtr = NULL; /* * If the optionName is NULL it means that we want * a list of all options and values. */ len = (option == NULL) ? 0 : strlen(option); Tcl_MutexLock(&threadMutex); tsdPtr = ThreadExistsInner(thrId); if (tsdPtr == NULL) { Tcl_MutexUnlock(&threadMutex); ErrorNoSuchThread(interp, thrId); return TCL_ERROR; } if (len == 0 || (len > 3 && option[1] == 'e' && option[2] == 'v' && !strncmp(option,"-eventmark", len))) { char buf[16]; if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-eventmark"); } snprintf(buf, sizeof(buf), "%d", tsdPtr->maxEventsCount); Tcl_DStringAppendElement(dsPtr, buf); if (len != 0) { Tcl_MutexUnlock(&threadMutex); return TCL_OK; } } if (len == 0 || (len > 2 && option[1] == 'u' && !strncmp(option,"-unwindonerror", len))) { int flag = tsdPtr->flags & THREAD_FLAGS_UNWINDONERROR; if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-unwindonerror"); } Tcl_DStringAppendElement(dsPtr, flag ? "1" : "0"); if (len != 0) { Tcl_MutexUnlock(&threadMutex); return TCL_OK; } } if (len == 0 || (len > 3 && option[1] == 'e' && option[2] == 'r' && !strncmp(option,"-errorstate", len))) { int flag = tsdPtr->flags & THREAD_FLAGS_INERROR; if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-errorstate"); } Tcl_DStringAppendElement(dsPtr, flag ? "1" : "0"); if (len != 0) { Tcl_MutexUnlock(&threadMutex); return TCL_OK; } } if (len != 0) { Tcl_AppendResult(interp, "bad option \"", option, "\", should be one of -eventmark, " "-unwindonerror or -errorstate", (void *)NULL); Tcl_MutexUnlock(&threadMutex); return TCL_ERROR; } Tcl_MutexUnlock(&threadMutex); return TCL_OK; } /* *---------------------------------------------------------------------- * * ThreadSetOption -- * * Results: * * Side effects: * *---------------------------------------------------------------------- */ static int ThreadSetOption( Tcl_Interp *interp, Tcl_ThreadId thrId, char *option, char *value ) { size_t len = strlen(option); ThreadSpecificData *tsdPtr = NULL; Tcl_MutexLock(&threadMutex); tsdPtr = ThreadExistsInner(thrId); if (tsdPtr == NULL) { Tcl_MutexUnlock(&threadMutex); ErrorNoSuchThread(interp, thrId); return TCL_ERROR; } if (len > 3 && option[1] == 'e' && option[2] == 'v' && !strncmp(option,"-eventmark", len)) { if (sscanf(value, "%d", &tsdPtr->maxEventsCount) != 1) { Tcl_AppendResult(interp, "expected integer but got \"", value, "\"", (void *)NULL); Tcl_MutexUnlock(&threadMutex); return TCL_ERROR; } } else if (len > 2 && option[1] == 'u' && !strncmp(option,"-unwindonerror", len)) { int flag = 0; if (Tcl_GetBoolean(interp, value, &flag) != TCL_OK) { Tcl_MutexUnlock(&threadMutex); return TCL_ERROR; } if (flag) { tsdPtr->flags |= THREAD_FLAGS_UNWINDONERROR; } else { tsdPtr->flags &= ~THREAD_FLAGS_UNWINDONERROR; } } else if (len > 3 && option[1] == 'e' && option[2] == 'r' && !strncmp(option,"-errorstate", len)) { int flag = 0; if (Tcl_GetBoolean(interp, value, &flag) != TCL_OK) { Tcl_MutexUnlock(&threadMutex); return TCL_ERROR; } if (flag) { tsdPtr->flags |= THREAD_FLAGS_INERROR; } else { tsdPtr->flags &= ~THREAD_FLAGS_INERROR; } } Tcl_MutexUnlock(&threadMutex); return TCL_OK; } /* *---------------------------------------------------------------------- * * TransferEventProc -- * * Handle a transfer event in the target thread. * * Results: * Returns 1 to indicate that the event was processed. * * Side effects: * Fills out the TransferResult struct. * *---------------------------------------------------------------------- */ static int TransferEventProc( Tcl_Event *evPtr, /* Really ThreadEvent */ TCL_UNUSED(int) ) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); TransferEvent *eventPtr = (TransferEvent *)evPtr; TransferResult *resultPtr = eventPtr->resultPtr; Tcl_Interp *interp = tsdPtr->interp; int code; const char* msg = NULL; if (interp == NULL) { /* * Reject transfer in case of a missing target. */ code = TCL_ERROR; msg = "target interp missing"; } else { /* * Add channel to current thread and interp. * See ThreadTransfer for more explanations. */ if (Tcl_IsChannelExisting(Tcl_GetChannelName(eventPtr->chan))) { /* * Reject transfer. Channel of same name already exists in target. */ code = TCL_ERROR; msg = "channel already exists in target"; } else { Tcl_SpliceChannel(eventPtr->chan); Tcl_RegisterChannel(interp, eventPtr->chan); Tcl_UnregisterChannel((Tcl_Interp *) NULL, eventPtr->chan); code = TCL_OK; /* Return success. */ } } if (resultPtr) { Tcl_MutexLock(&threadMutex); resultPtr->resultCode = code; if (msg != NULL) { size_t size = strlen(msg)+1; resultPtr->resultMsg = (char *)memcpy(Tcl_Alloc(size), msg, size); } Tcl_ConditionNotify(&resultPtr->done); Tcl_MutexUnlock(&threadMutex); } return 1; } /* *---------------------------------------------------------------------- * * ThreadFreeProc -- * * Called when we are exiting and memory needs to be freed. * * Results: * None. * * Side effects: * Clears up mem specified in clientData * *---------------------------------------------------------------------- */ static void ThreadFreeProc( void *clientData ) { /* * This will free send and/or callback structures * since both are the same in the beginning. */ ThreadSendData *anyPtr = (ThreadSendData *)clientData; if (anyPtr) { if (anyPtr->clientData) { (*anyPtr->freeProc)(anyPtr->clientData); } Tcl_Free(anyPtr); } } /* *---------------------------------------------------------------------- * * ThreadDeleteEvent -- * * This is called from the ThreadExitProc to delete memory related * to events that we put on the queue. * * Results: * 1 it was our event and we want it removed, 0 otherwise. * * Side effects: * It cleans up our events in the event queue for this thread. * *---------------------------------------------------------------------- */ static int ThreadDeleteEvent( Tcl_Event *eventPtr, /* Really ThreadEvent */ TCL_UNUSED(void *) /* dummy */ ) { if (eventPtr->proc == ThreadEventProc) { /* * Regular script event. Just dispose memory */ ThreadEvent *evPtr = (ThreadEvent*)eventPtr; if (evPtr->sendData) { ThreadFreeProc(evPtr->sendData); evPtr->sendData = NULL; } if (evPtr->clbkData) { ThreadFreeProc(evPtr->clbkData); evPtr->clbkData = NULL; } return 1; } if (eventPtr->proc == TransferEventProc) { /* * A channel is in flight toward the thread just exiting. * Pass it back to the originator, if possible. * Else kill it. */ TransferEvent* evPtr = (TransferEvent *) eventPtr; if (evPtr->resultPtr == (TransferResult *) NULL) { /* No thread to pass the channel back to. Kill it. * This requires to splice it temporarily into our channel * list and then forcing the ref.counter down to the real * value of zero. This destroys the channel. */ Tcl_SpliceChannel(evPtr->chan); Tcl_UnregisterChannel((Tcl_Interp *) NULL, evPtr->chan); return 1; } /* Our caller (ThreadExitProc) will pass the channel back. */ return 1; } /* * If it was NULL, we were in the middle of servicing the event * and it should be removed */ return (eventPtr->proc == NULL); } /* *---------------------------------------------------------------------- * * ThreadExitProc -- * * This is called when the thread exits. * * Results: * None. * * Side effects: * It unblocks anyone that is waiting on a send to this thread. * It cleans up any events in the event queue for this thread. * *---------------------------------------------------------------------- */ static void ThreadExitProc( void *clientData ) { char *threadEvalScript = (char *)clientData; const char *diemsg = "target thread died"; ThreadEventResult *resultPtr, *nextPtr; Tcl_ThreadId self = Tcl_GetCurrentThread(); ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); TransferResult *tResultPtr, *tNextPtr; if (threadEvalScript && threadEvalScript != threadEmptyResult) { Tcl_Free(threadEvalScript); } Tcl_MutexLock(&threadMutex); /* * NaviServer/AOLserver and threadpool threads get started/stopped * out of the control of this interface so this is * the first chance to split them out of the thread list. */ ListRemoveInner(tsdPtr); /* * Delete events posted to our queue while we were running. * For threads exiting from the thread::wait command, this * has already been done in ThreadWait() function. * For one-shot threads, having something here is a very * strange condition. It *may* happen if somebody posts us * an event while we were in the middle of processing some * lengthly user script. It is unlikely to happen, though. */ Tcl_DeleteEvents((Tcl_EventDeleteProc*)ThreadDeleteEvent, NULL); /* * Walk the list of threads waiting for result from us * and inform them that we're about to exit. */ for (resultPtr = resultList; resultPtr; resultPtr = nextPtr) { nextPtr = resultPtr->nextPtr; if (resultPtr->srcThreadId == self) { /* * We are going away. By freeing up the result we signal * to the other thread we don't care about the result. */ SpliceOut(resultPtr, resultList); Tcl_Free(resultPtr); } else if (resultPtr->dstThreadId == self) { /* * Dang. The target is going away. Unblock the caller. * The result string must be dynamically allocated * because the main thread is going to call free on it. */ resultPtr->result = strcpy(Tcl_Alloc(1+strlen(diemsg)), diemsg); resultPtr->code = TCL_ERROR; resultPtr->errorCode = resultPtr->errorInfo = NULL; Tcl_ConditionNotify(&resultPtr->done); } } for (tResultPtr = transferList; tResultPtr; tResultPtr = tNextPtr) { tNextPtr = tResultPtr->nextPtr; if (tResultPtr->srcThreadId == self) { /* * We are going away. By freeing up the result we signal * to the other thread we don't care about the result. * * This should not happen, as this thread should be in * ThreadTransfer at location (*). */ SpliceOut(tResultPtr, transferList); Tcl_Free(tResultPtr); } else if (tResultPtr->dstThreadId == self) { /* * Dang. The target is going away. Unblock the caller. * The result string must be dynamically allocated * because the main thread is going to call free on it. */ tResultPtr->resultMsg = strcpy((char *)Tcl_Alloc(1+strlen(diemsg)), diemsg); tResultPtr->resultCode = TCL_ERROR; Tcl_ConditionNotify(&tResultPtr->done); } } Tcl_MutexUnlock(&threadMutex); } /* *---------------------------------------------------------------------- * * ThreadGetHandle -- * * Construct the handle of the thread which is suitable * to pass to Tcl. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void ThreadGetHandle( Tcl_ThreadId thrId, char *handlePtr ) { snprintf(handlePtr, THREAD_HNDLMAXLEN, THREAD_HNDLPREFIX "%p", thrId); } /* *---------------------------------------------------------------------- * * ThreadGetId -- * * Returns the ID of thread given it's Tcl handle. * * Results: * Thread ID. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ThreadGetId( Tcl_Interp *interp, Tcl_Obj *handleObj, Tcl_ThreadId *thrIdPtr ) { const char *thrHandle = Tcl_GetString(handleObj); if (sscanf(thrHandle, THREAD_HNDLPREFIX "%p", thrIdPtr) == 1) { return TCL_OK; } Tcl_AppendResult(interp, "invalid thread handle \"", thrHandle, "\"", (void *)NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * ErrorNoSuchThread -- * * Convenience function to set interpreter result when the thread * given by it's ID cannot be found. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void ErrorNoSuchThread( Tcl_Interp *interp, Tcl_ThreadId thrId ) { char thrHandle[THREAD_HNDLMAXLEN]; ThreadGetHandle(thrId, thrHandle); Tcl_AppendResult(interp, "thread \"", thrHandle, "\" does not exist", (void *)NULL); } /* *---------------------------------------------------------------------- * * ThreadCutChannel -- * * Dissociate a Tcl channel from the current thread/interp. * * Results: * None. * * Side effects: * Events still pending in the thread event queue and ready to fire * are not processed. * *---------------------------------------------------------------------- */ static void ThreadCutChannel( Tcl_Interp *interp, Tcl_Channel chan ) { Tcl_DriverWatchProc *watchProc; Tcl_ClearChannelHandlers(chan); watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(chan)); /* * This effectively disables processing of pending * events which are ready to fire for the given * channel. If we do not do this, events will hit * the detached channel which is potentially being * owned by some other thread. This will wreck havoc * on our memory and eventually badly hurt us... */ if (watchProc) { (*watchProc)(Tcl_GetChannelInstanceData(chan), 0); } /* * Artificially bump the channel reference count * which protects us from channel being closed * during the Tcl_UnregisterChannel(). */ Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); Tcl_UnregisterChannel(interp, chan); Tcl_CutChannel(chan); } /* EOF $RCSfile: threadCmd.c,v $ */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/tclXkeylist.h0000644003604700454610000000404114726633451015416 0ustar dgp771div/* * tclXkeylist.h -- * * Extended Tcl keyed list commands and interfaces. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- */ #ifndef _KEYLIST_H_ #define _KEYLIST_H_ #include "tclThreadInt.h" /* * Keyed list object interface commands */ MODULE_SCOPE Tcl_Obj* TclX_NewKeyedListObj(); MODULE_SCOPE void TclX_KeyedListInit(Tcl_Interp*); MODULE_SCOPE int TclX_KeyedListGet(Tcl_Interp*, Tcl_Obj*, const char*, Tcl_Obj**); MODULE_SCOPE int TclX_KeyedListSet(Tcl_Interp*, Tcl_Obj*, const char*, Tcl_Obj*); MODULE_SCOPE int TclX_KeyedListDelete(Tcl_Interp*, Tcl_Obj*, const char*); MODULE_SCOPE int TclX_KeyedListGetKeys(Tcl_Interp*, Tcl_Obj*, const char*, Tcl_Obj**); /* * This is defined in keylist.c. We need it here * to be able to plug-in our custom keyed-list * object duplicator which produces proper deep * copies of the keyed-list objects. The standard * one produces shallow copies which are not good * for usage in the thread shared variables code. */ MODULE_SCOPE const Tcl_ObjType keyedListType; /* * Exported for usage in Sv_DuplicateObj. This is slightly * modified version of the DupKeyedListInternalRep() function. * It does a proper deep-copy of the keyed list object. */ MODULE_SCOPE void DupKeyedListInternalRepShared(Tcl_Obj*, Tcl_Obj*); #endif /* _KEYLIST_H_ */ /* EOF $RCSfile: tclXkeylist.h,v $ */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/tclXkeylist.c0000644003604700454610000012162714726633451015423 0ustar dgp771div/* * tclXkeylist.c -- * * Extended Tcl keyed list commands and interfaces. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. * *----------------------------------------------------------------------------- * * This file was synthetized from the TclX distribution and made * self-containing in order to encapsulate the keyed list datatype * for the inclusion in the Tcl threading extension. I have made * some minor changes to it in order to get internal object handling * thread-safe and allow for this datatype to be used from within * the thread shared variables implementation. * * For any questions, contant Zoran Vasiljevic (zoran@archiware.com) *----------------------------------------------------------------------------- */ #include "threadSvCmd.h" #include "tclXkeylist.h" #include /*---------------------------------------------------------------------------*/ /*---------------------------------------------------------------------------*/ /* Stuff copied verbatim from the rest of TclX to avoid dependencies */ /*---------------------------------------------------------------------------*/ /*---------------------------------------------------------------------------*/ /* * Assert macro for use in TclX. Some GCCs libraries are missing a function * used by their macro, so we define out own. */ #ifdef TCLX_DEBUG # define TclX_Assert(expr) ((expr) ? NULL : \ panic("TclX assertion failure: %s:%d \"%s\"\n",\ __FILE__, __LINE__, "expr")) #else # define TclX_Assert(expr) #endif /* * Macro that behaves like strdup, only uses Tcl_Alloc. Also macro that does the * same with a string that might contain zero bytes, */ #define ckstrdup(sourceStr) \ (strcpy ((char *)Tcl_Alloc (strlen (sourceStr) + 1), sourceStr)) #define ckbinstrdup(sourceStr, length) \ ((char *) memcpy ((char *)Tcl_Alloc (length + 1), sourceStr, length + 1)) /* * Used to return argument messages by most commands. */ static const char *tclXWrongArgs = "wrong # args: "; static const Tcl_ObjType *listType; /*----------------------------------------------------------------------------- * TclX_IsNullObj -- * * Check if an object is {}, either in list or zero-lemngth string form, with * out forcing a conversion. * * Parameters: * o objPtr - Object to check. * Returns: * 1 if NULL, 0 if not. *----------------------------------------------------------------------------- */ static int TclX_IsNullObj ( Tcl_Obj *objPtr ) { if (objPtr->typePtr == NULL) { return (objPtr->length == 0); } else if (objPtr->typePtr == listType) { Tcl_Size length; Tcl_ListObjLength(NULL, objPtr, &length); return (length == 0); } (void)Tcl_GetString(objPtr); return (objPtr->length == 0); } /*----------------------------------------------------------------------------- * TclX_AppendObjResult -- * * Append a variable number of strings onto the object result already * present for an interpreter. If the object is shared, the current contents * are discarded. * * Parameters: * o interp - Interpreter to set the result in. * o args - Strings to append, terminated by a NULL. *----------------------------------------------------------------------------- */ static void TclX_AppendObjResult(Tcl_Interp *interp, ...) { Tcl_Obj *resultPtr; va_list argList; char *string; va_start(argList, interp); resultPtr = Tcl_GetObjResult (interp); if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_NewStringObj(NULL, 0); Tcl_SetObjResult(interp, resultPtr); } while (1) { string = va_arg(argList, char *); if (string == NULL) { break; } Tcl_AppendToObj (resultPtr, string, TCL_INDEX_NONE); } va_end(argList); } /*----------------------------------------------------------------------------- * TclX_WrongArgs -- * * Easily create "wrong # args" error messages. * * Parameters: * o commandNameObj - Object containing name of command (objv[0]) * o string - Text message to append. * Returns: * TCL_ERROR *----------------------------------------------------------------------------- */ static int TclX_WrongArgs( Tcl_Interp *interp, Tcl_Obj *commandNameObj, const char *string ) { const char *commandName = Tcl_GetString(commandNameObj); Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); Tcl_ResetResult(interp); Tcl_AppendStringsToObj (resultPtr, tclXWrongArgs, commandName, NULL); if (*string != '\0') { Tcl_AppendStringsToObj (resultPtr, " ", string, (void *)NULL); } return TCL_ERROR; } /*---------------------------------------------------------------------------*/ /*---------------------------------------------------------------------------*/ /* Here is where the original file begins */ /*---------------------------------------------------------------------------*/ /*---------------------------------------------------------------------------*/ /* * Keyed lists are stored as arrays recursively defined objects. The data * portion of a keyed list entry is a Tcl_Obj which may be a keyed list object * or any other Tcl object. Since determine the structure of a keyed list is * lazy (you don't know if an element is data or another keyed list) until it * is accessed, the object can be transformed into a keyed list from a Tcl * string or list. */ /* * An entry in a keyed list array. (FIX: Should key be object?) */ typedef struct { char *key; Tcl_Obj *valuePtr; } keylEntry_t; /* * Internal representation of a keyed list object. */ typedef struct { size_t arraySize; /* Current slots available in the array. */ size_t numEntries; /* Number of actual entries in the array. */ keylEntry_t *entries; /* Array of keyed list entries. */ } keylIntObj_t; /* * Amount to increment array size by when it needs to grow. */ #define KEYEDLIST_ARRAY_INCR_SIZE 16 /* * Macro to duplicate a child entry of a keyed list if it is share by more * than the parent. */ #define DupSharedKeyListChild(keylIntPtr, idx) \ if (Tcl_IsShared (keylIntPtr->entries [idx].valuePtr)) { \ keylIntPtr->entries [idx].valuePtr = \ Tcl_DuplicateObj (keylIntPtr->entries [idx].valuePtr); \ Tcl_IncrRefCount (keylIntPtr->entries [idx].valuePtr); \ } /* * Macros to validate an keyed list object or internal representation */ #ifdef TCLX_DEBUG # define KEYL_OBJ_ASSERT(keylAPtr) {\ TclX_Assert (keylAPtr->typePtr == &keyedListType); \ ValidateKeyedList (keylAIntPtr); \ } # define KEYL_REP_ASSERT(keylAIntPtr) \ ValidateKeyedList (keylAIntPtr) #else # define KEYL_REP_ASSERT(keylAIntPtr) #endif /* * Prototypes of internal functions. */ #ifdef TCLX_DEBUG static void ValidateKeyedList(keylIntObj_t *keylIntPtr); #endif static int ValidateKey(Tcl_Interp *interp, const char *key, Tcl_Size keyLen, int isPath); static keylIntObj_t * AllocKeyedListIntRep(void); static void FreeKeyedListData(keylIntObj_t *keylIntPtr); static void EnsureKeyedListSpace(keylIntObj_t *keylIntPtr, size_t newNumEntries); static void DeleteKeyedListEntry(keylIntObj_t *keylIntPtr, size_t entryIdx); static size_t FindKeyedListEntry(keylIntObj_t *keylIntPtr, const char *key, size_t *keyLenPtr, const char **nextSubKeyPtr); static int ObjToKeyedListEntry(Tcl_Interp *interp, Tcl_Obj *objPtr, keylEntry_t *entryPtr); static void DupKeyedListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeKeyedListInternalRep(Tcl_Obj *keylPtr); static int SetKeyedListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfKeyedList(Tcl_Obj *keylPtr); static int Tcl_KeylgetObjCmd(void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); static int Tcl_KeylsetObjCmd(void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); static int Tcl_KeyldelObjCmd(void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); static int Tcl_KeylkeysObjCmd(void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* * Type definition. */ const Tcl_ObjType keyedListType = { "keyedList", /* name */ FreeKeyedListInternalRep, /* freeIntRepProc */ DupKeyedListInternalRep, /* dupIntRepProc */ UpdateStringOfKeyedList, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; /*----------------------------------------------------------------------------- * ValidateKeyedList -- * Validate a keyed list (only when TCLX_DEBUG is enabled). * Parameters: * o keylIntPtr - Keyed list internal representation. *----------------------------------------------------------------------------- */ #ifdef TCLX_DEBUG static void ValidateKeyedList (keylIntPtr) keylIntObj_t *keylIntPtr; { size_t idx; TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); TclX_Assert ((keylIntPtr->arraySize > 0) ? (keylIntPtr->entries != NULL) : 1); TclX_Assert ((keylIntPtr->numEntries > 0) ? (keylIntPtr->entries != NULL) : 1); for (idx = 0; idx < keylIntPtr->numEntries; idx++) { keylEntry_t *entryPtr = &(keylIntPtr->entries [idx]); TclX_Assert (entryPtr->key != NULL); TclX_Assert (entryPtr->valuePtr->refCount >= 1); if (entryPtr->valuePtr->typePtr == &keyedListType) { ValidateKeyedList (entryPtr->valuePtr->internalRep.twoPtrValue.ptr1); } } } #endif /*----------------------------------------------------------------------------- * ValidateKey -- * Check that a key or keypath string is a valid value. * * Parameters: * o interp - Used to return error messages. * o key - Key string to check. * o keyLen - Length of the string, used to check for binary data. * o isPath - 1 if this is a key path, 0 if its a simple key and * thus "." is illegal. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ValidateKey( Tcl_Interp *interp, const char *key, Tcl_Size keyLen, int isPath ) { const char *keyp; if (strlen(key) != (size_t)keyLen) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "keyed list key may not be a ", "binary string", (char *) NULL); return TCL_ERROR; } if (key[0] == '\0') { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "keyed list key may not be an ", "empty string", (char *) NULL); return TCL_ERROR; } for (keyp = key; *keyp != '\0'; keyp++) { if ((!isPath) && (*keyp == '.')) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "keyed list key may not contain a \".\"; ", "it is used as a separator in key paths", (char *) NULL); return TCL_ERROR; } } return TCL_OK; } /*----------------------------------------------------------------------------- * AllocKeyedListIntRep -- * Allocate an and initialize the keyed list internal representation. * * Returns: * A pointer to the keyed list internal structure. *----------------------------------------------------------------------------- */ static keylIntObj_t * AllocKeyedListIntRep(void) { keylIntObj_t *keylIntPtr; keylIntPtr = (keylIntObj_t *)Tcl_Alloc(sizeof(keylIntObj_t)); keylIntPtr->arraySize = 0; keylIntPtr->numEntries = 0; keylIntPtr->entries = NULL; return keylIntPtr; } /*----------------------------------------------------------------------------- * FreeKeyedListData -- * Free the internal representation of a keyed list. * * Parameters: * o keylIntPtr - Keyed list internal structure to free. *----------------------------------------------------------------------------- */ static void FreeKeyedListData( keylIntObj_t *keylIntPtr ) { size_t idx; for (idx = 0; idx < keylIntPtr->numEntries ; idx++) { Tcl_Free(keylIntPtr->entries[idx].key); Tcl_DecrRefCount (keylIntPtr->entries[idx].valuePtr); } if (keylIntPtr->entries != NULL) Tcl_Free(keylIntPtr->entries); Tcl_Free(keylIntPtr); } /*----------------------------------------------------------------------------- * EnsureKeyedListSpace -- * Ensure there is enough room in a keyed list array for a certain number * of entries, expanding if necessary. * * Parameters: * o keylIntPtr - Keyed list internal representation. * o newNumEntries - The number of entries that are going to be added to * the keyed list. *----------------------------------------------------------------------------- */ static void EnsureKeyedListSpace( keylIntObj_t *keylIntPtr, size_t newNumEntries ) { KEYL_REP_ASSERT (keylIntPtr); if ((keylIntPtr->arraySize) < newNumEntries + keylIntPtr->numEntries) { size_t newSize = keylIntPtr->arraySize + newNumEntries + KEYEDLIST_ARRAY_INCR_SIZE; if (keylIntPtr->entries == NULL) { keylIntPtr->entries = (keylEntry_t *) Tcl_Alloc(newSize * sizeof(keylEntry_t)); } else { keylIntPtr->entries = (keylEntry_t *) Tcl_Realloc(keylIntPtr->entries, newSize * sizeof(keylEntry_t)); } keylIntPtr->arraySize = newSize; } KEYL_REP_ASSERT (keylIntPtr); } /*----------------------------------------------------------------------------- * DeleteKeyedListEntry -- * Delete an entry from a keyed list. * * Parameters: * o keylIntPtr - Keyed list internal representation. * o entryIdx - Index of entry to delete. *----------------------------------------------------------------------------- */ static void DeleteKeyedListEntry ( keylIntObj_t *keylIntPtr, size_t entryIdx ) { size_t idx; Tcl_Free(keylIntPtr->entries [entryIdx].key); Tcl_DecrRefCount (keylIntPtr->entries [entryIdx].valuePtr); for (idx = entryIdx; idx < keylIntPtr->numEntries - 1; idx++) keylIntPtr->entries [idx] = keylIntPtr->entries [idx + 1]; keylIntPtr->numEntries--; KEYL_REP_ASSERT (keylIntPtr); } /*----------------------------------------------------------------------------- * FindKeyedListEntry -- * Find an entry in keyed list. * * Parameters: * o keylIntPtr - Keyed list internal representation. * o key - Name of key to search for. * o keyLenPtr - In not NULL, the length of the key for this * level is returned here. This excludes subkeys and the `.' delimiters. * o nextSubKeyPtr - If not NULL, the start of the name of the next * sub-key within key is returned. * Returns: * Index of the entry or TCL_INDEX_NONE if not found. *----------------------------------------------------------------------------- */ static size_t FindKeyedListEntry( keylIntObj_t *keylIntPtr, const char *key, size_t *keyLenPtr, const char **nextSubKeyPtr ) { const char *keySeparPtr; size_t keyLen; size_t findIdx; keySeparPtr = strchr(key, '.'); if (keySeparPtr != NULL) { keyLen = (size_t)(keySeparPtr - key); } else { keyLen = strlen (key); } for (findIdx = 0; findIdx < keylIntPtr->numEntries; findIdx++) { if ((strncmp (keylIntPtr->entries [findIdx].key, key, keyLen) == 0) && (keylIntPtr->entries [findIdx].key [keyLen] == '\0')) break; } if (nextSubKeyPtr != NULL) { if (keySeparPtr == NULL) { *nextSubKeyPtr = NULL; } else { *nextSubKeyPtr = keySeparPtr + 1; } } if (keyLenPtr != NULL) { *keyLenPtr = keyLen; } if (findIdx >= keylIntPtr->numEntries) { return TCL_INDEX_NONE; } return findIdx; } /*----------------------------------------------------------------------------- * ObjToKeyedListEntry -- * Convert an object to a keyed list entry. (Keyword/value pair). * * Parameters: * o interp - Used to return error messages, if not NULL. * o objPtr - Object to convert. Each entry must be a two element list, * with the first element being the key and the second being the * value. * o entryPtr - The keyed list entry to initialize from the object. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ static int ObjToKeyedListEntry( Tcl_Interp *interp, Tcl_Obj *objPtr, keylEntry_t *entryPtr ) { Tcl_Size objc; Tcl_Obj **objv; const char *key; if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { Tcl_ResetResult (interp); Tcl_AppendStringsToObj(Tcl_GetObjResult (interp), "keyed list entry not a valid list, ", "found \"", Tcl_GetString(objPtr), "\"", (char *) NULL); return TCL_ERROR; } if (objc != 2) { Tcl_AppendStringsToObj(Tcl_GetObjResult (interp), "keyed list entry must be a two ", "element list, found \"", Tcl_GetString(objPtr), "\"", (char *) NULL); return TCL_ERROR; } key = Tcl_GetString(objv[0]); if (ValidateKey(interp, key, objv[0]->length, 0) == TCL_ERROR) { return TCL_ERROR; } entryPtr->key = ckstrdup(key); entryPtr->valuePtr = Tcl_DuplicateObj(objv [1]); Tcl_IncrRefCount(entryPtr->valuePtr); return TCL_OK; } /*----------------------------------------------------------------------------- * FreeKeyedListInternalRep -- * Free the internal representation of a keyed list. * * Parameters: * o keylPtr - Keyed list object being deleted. *----------------------------------------------------------------------------- */ static void FreeKeyedListInternalRep( Tcl_Obj *keylPtr ) { FreeKeyedListData((keylIntObj_t *)keylPtr->internalRep.twoPtrValue.ptr1); } /*----------------------------------------------------------------------------- * DupKeyedListInternalRep -- * Duplicate the internal representation of a keyed list. * * Parameters: * o srcPtr - Keyed list object to copy. * o copyPtr - Target object to copy internal representation to. *----------------------------------------------------------------------------- */ static void DupKeyedListInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr ) { keylIntObj_t *srcIntPtr = (keylIntObj_t *) srcPtr->internalRep.twoPtrValue.ptr1; keylIntObj_t *copyIntPtr; size_t idx; KEYL_REP_ASSERT (srcIntPtr); copyIntPtr = (keylIntObj_t *)Tcl_Alloc(sizeof(keylIntObj_t)); copyIntPtr->arraySize = srcIntPtr->arraySize; copyIntPtr->numEntries = srcIntPtr->numEntries; copyIntPtr->entries = (keylEntry_t *) Tcl_Alloc(copyIntPtr->arraySize * sizeof(keylEntry_t)); for (idx = 0; idx < srcIntPtr->numEntries ; idx++) { copyIntPtr->entries [idx].key = ckstrdup (srcIntPtr->entries [idx].key); copyIntPtr->entries [idx].valuePtr = srcIntPtr->entries [idx].valuePtr; Tcl_IncrRefCount (copyIntPtr->entries [idx].valuePtr); } copyPtr->internalRep.twoPtrValue.ptr1 = copyIntPtr; copyPtr->typePtr = &keyedListType; KEYL_REP_ASSERT (copyIntPtr); } /*----------------------------------------------------------------------------- * DupKeyedListInternalRepShared -- * Same as DupKeyedListInternalRepbut does not reference objects * from the srcPtr list. It duplicates them and stores the copy * in the list-copy object. * * Parameters: * o srcPtr - Keyed list object to copy. * o copyPtr - Target object to copy internal representation to. *----------------------------------------------------------------------------- */ void DupKeyedListInternalRepShared ( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr ) { keylIntObj_t *srcIntPtr = (keylIntObj_t *) srcPtr->internalRep.twoPtrValue.ptr1; keylIntObj_t *copyIntPtr; size_t idx; KEYL_REP_ASSERT (srcIntPtr); copyIntPtr = (keylIntObj_t *)Tcl_Alloc(sizeof(keylIntObj_t)); copyIntPtr->arraySize = srcIntPtr->arraySize; copyIntPtr->numEntries = srcIntPtr->numEntries; copyIntPtr->entries = (keylEntry_t *) Tcl_Alloc(copyIntPtr->arraySize * sizeof(keylEntry_t)); for (idx = 0; idx < srcIntPtr->numEntries ; idx++) { copyIntPtr->entries[idx].key = ckstrdup (srcIntPtr->entries [idx].key); copyIntPtr->entries[idx].valuePtr = Sv_DuplicateObj (srcIntPtr->entries [idx].valuePtr); Tcl_IncrRefCount(copyIntPtr->entries [idx].valuePtr); } copyPtr->internalRep.twoPtrValue.ptr1 = copyIntPtr; copyPtr->typePtr = &keyedListType; KEYL_REP_ASSERT (copyIntPtr); } /*----------------------------------------------------------------------------- * SetKeyedListFromAny -- * Convert an object to a keyed list from its string representation. Only * the first level is converted, as there is no way of knowing how far down * the keyed list recurses until lower levels are accessed. * * Parameters: * o objPtr - Object to convert to a keyed list. *----------------------------------------------------------------------------- */ static int SetKeyedListFromAny( Tcl_Interp *interp, Tcl_Obj *objPtr ) { keylIntObj_t *keylIntPtr; Tcl_Size idx; Tcl_Size objc; Tcl_Obj **objv; if (Tcl_ListObjGetElements (interp, objPtr, &objc, &objv) != TCL_OK) return TCL_ERROR; keylIntPtr = AllocKeyedListIntRep (); EnsureKeyedListSpace (keylIntPtr, objc); for (idx = 0; idx < objc; idx++) { if (ObjToKeyedListEntry (interp, objv [idx], &(keylIntPtr->entries [keylIntPtr->numEntries])) != TCL_OK) goto errorExit; keylIntPtr->numEntries++; } if ((objPtr->typePtr != NULL) && (objPtr->typePtr->freeIntRepProc != NULL)) { (*objPtr->typePtr->freeIntRepProc) (objPtr); } objPtr->internalRep.twoPtrValue.ptr1 = keylIntPtr; objPtr->typePtr = &keyedListType; KEYL_REP_ASSERT (keylIntPtr); return TCL_OK; errorExit: FreeKeyedListData (keylIntPtr); return TCL_ERROR; } /*----------------------------------------------------------------------------- * UpdateStringOfKeyedList -- * Update the string representation of a keyed list. * * Parameters: * o objPtr - Object to convert to a keyed list. *----------------------------------------------------------------------------- */ static void UpdateStringOfKeyedList( Tcl_Obj *keylPtr ) { #define UPDATE_STATIC_SIZE 32 size_t idx; Tcl_Obj **listObjv, *entryObjv [2], *tmpListObj; Tcl_Obj *staticListObjv [UPDATE_STATIC_SIZE]; char *listStr; keylIntObj_t *keylIntPtr = (keylIntObj_t *) keylPtr->internalRep.twoPtrValue.ptr1; /* * Conversion to strings is done via list objects to support binary data. */ if (keylIntPtr->numEntries > UPDATE_STATIC_SIZE) { listObjv = (Tcl_Obj **) Tcl_Alloc(keylIntPtr->numEntries * sizeof(Tcl_Obj *)); } else { listObjv = staticListObjv; } /* * Convert each keyed list entry to a two element list object. No * need to incr/decr ref counts, the list objects will take care of that. * FIX: Keeping key as string object will speed this up. */ for (idx = 0; idx < keylIntPtr->numEntries; idx++) { entryObjv [0] = Tcl_NewStringObj(keylIntPtr->entries [idx].key, strlen (keylIntPtr->entries [idx].key)); entryObjv [1] = keylIntPtr->entries [idx].valuePtr; listObjv [idx] = Tcl_NewListObj (2, entryObjv); } tmpListObj = Tcl_NewListObj (keylIntPtr->numEntries, listObjv); listStr = Tcl_GetString(tmpListObj); keylPtr->bytes = ckbinstrdup(listStr, tmpListObj->length); keylPtr->length = tmpListObj->length; Tcl_DecrRefCount (tmpListObj); if (listObjv != staticListObjv) Tcl_Free(listObjv); } /*----------------------------------------------------------------------------- * TclX_NewKeyedListObj -- * Create and initialize a new keyed list object. * * Returns: * A pointer to the object. *----------------------------------------------------------------------------- */ Tcl_Obj * TclX_NewKeyedListObj(void) { Tcl_Obj *keylPtr = Tcl_NewObj (); keylIntObj_t *keylIntPtr = AllocKeyedListIntRep (); keylPtr->internalRep.twoPtrValue.ptr1 = keylIntPtr; keylPtr->typePtr = &keyedListType; return keylPtr; } /*----------------------------------------------------------------------------- * TclX_KeyedListGet -- * Retrieve a key value from a keyed list. * * Parameters: * o interp - Error message will be return in result if there is an error. * o keylPtr - Keyed list object to get key from. * o key - The name of the key to extract. Will recusively process sub-keys * seperated by `.'. * o valueObjPtrPtr - If the key is found, a pointer to the key object * is returned here. NULL is returned if the key is not present. * Returns: * o TCL_OK - If the key value was returned. * o TCL_BREAK - If the key was not found. * o TCL_ERROR - If an error occured. *----------------------------------------------------------------------------- */ int TclX_KeyedListGet( Tcl_Interp *interp, Tcl_Obj *keylPtr, const char *key, Tcl_Obj **valuePtrPtr ) { keylIntObj_t *keylIntPtr; const char *nextSubKey; size_t findIdx; if (keylPtr->typePtr != &keyedListType) { if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) { return TCL_ERROR; } } keylIntPtr = (keylIntObj_t *)keylPtr->internalRep.twoPtrValue.ptr1; KEYL_REP_ASSERT (keylIntPtr); findIdx = FindKeyedListEntry (keylIntPtr, key, NULL, &nextSubKey); /* * If not found, return status. */ if (findIdx == TCL_INDEX_NONE) { *valuePtrPtr = NULL; return TCL_BREAK; } /* * If we are at the last subkey, return the entry, otherwise recurse * down looking for the entry. */ if (nextSubKey == NULL) { *valuePtrPtr = keylIntPtr->entries [findIdx].valuePtr; return TCL_OK; } else { return TclX_KeyedListGet (interp, keylIntPtr->entries [findIdx].valuePtr, nextSubKey, valuePtrPtr); } } /*----------------------------------------------------------------------------- * TclX_KeyedListSet -- * Set a key value in keyed list object. * * Parameters: * o interp - Error message will be return in result object. * o keylPtr - Keyed list object to update. * o key - The name of the key to extract. Will recusively process * sub-key seperated by `.'. * o valueObjPtr - The value to set for the key. * Returns: * TCL_OK or TCL_ERROR. *----------------------------------------------------------------------------- */ int TclX_KeyedListSet( Tcl_Interp *interp, Tcl_Obj *keylPtr, const char *key, Tcl_Obj *valuePtr ) { keylIntObj_t *keylIntPtr; const char *nextSubKey; size_t findIdx; int status; size_t keyLen; Tcl_Obj *newKeylPtr; if (keylPtr->typePtr != &keyedListType) { if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) { return TCL_ERROR; } } keylIntPtr = (keylIntObj_t *)keylPtr->internalRep.twoPtrValue.ptr1; KEYL_REP_ASSERT (keylIntPtr); findIdx = FindKeyedListEntry (keylIntPtr, key, &keyLen, &nextSubKey); /* * If we are at the last subkey, either update or add an entry. */ if (nextSubKey == NULL) { if (findIdx == TCL_INDEX_NONE) { EnsureKeyedListSpace (keylIntPtr, 1); findIdx = keylIntPtr->numEntries; keylIntPtr->numEntries++; } else { Tcl_Free(keylIntPtr->entries [findIdx].key); Tcl_DecrRefCount (keylIntPtr->entries [findIdx].valuePtr); } keylIntPtr->entries [findIdx].key = (char *) Tcl_Alloc(keyLen + 1); strncpy (keylIntPtr->entries [findIdx].key, key, keyLen); keylIntPtr->entries [findIdx].key [keyLen] = '\0'; keylIntPtr->entries [findIdx].valuePtr = valuePtr; Tcl_IncrRefCount (valuePtr); Tcl_InvalidateStringRep (keylPtr); KEYL_REP_ASSERT (keylIntPtr); return TCL_OK; } /* * If we are not at the last subkey, recurse down, creating new * entries if neccessary. If this level key was not found, it * means we must build new subtree. Don't insert the new tree until we * come back without error. */ if (findIdx != TCL_INDEX_NONE) { DupSharedKeyListChild (keylIntPtr, findIdx); status = TclX_KeyedListSet (interp, keylIntPtr->entries [findIdx].valuePtr, nextSubKey, valuePtr); if (status == TCL_OK) { Tcl_InvalidateStringRep (keylPtr); } KEYL_REP_ASSERT (keylIntPtr); return status; } else { newKeylPtr = TclX_NewKeyedListObj (); if (TclX_KeyedListSet (interp, newKeylPtr, nextSubKey, valuePtr) != TCL_OK) { Tcl_DecrRefCount (newKeylPtr); return TCL_ERROR; } EnsureKeyedListSpace (keylIntPtr, 1); findIdx = keylIntPtr->numEntries++; keylIntPtr->entries [findIdx].key = (char *) Tcl_Alloc(keyLen + 1); strncpy (keylIntPtr->entries [findIdx].key, key, keyLen); keylIntPtr->entries [findIdx].key [keyLen] = '\0'; keylIntPtr->entries [findIdx].valuePtr = newKeylPtr; Tcl_IncrRefCount (newKeylPtr); Tcl_InvalidateStringRep (keylPtr); KEYL_REP_ASSERT (keylIntPtr); return TCL_OK; } } /*----------------------------------------------------------------------------- * TclX_KeyedListDelete -- * Delete a key value from keyed list. * * Parameters: * o interp - Error message will be return in result if there is an error. * o keylPtr - Keyed list object to update. * o key - The name of the key to extract. Will recusively process * sub-key seperated by `.'. * Returns: * o TCL_OK - If the key was deleted. * o TCL_BREAK - If the key was not found. * o TCL_ERROR - If an error occured. *----------------------------------------------------------------------------- */ int TclX_KeyedListDelete( Tcl_Interp *interp, Tcl_Obj *keylPtr, const char *key ) { keylIntObj_t *keylIntPtr, *subKeylIntPtr; const char *nextSubKey; size_t findIdx; int status; if (keylPtr->typePtr != &keyedListType) { if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) { return TCL_ERROR; } } keylIntPtr = (keylIntObj_t *)keylPtr->internalRep.twoPtrValue.ptr1; findIdx = FindKeyedListEntry (keylIntPtr, key, NULL, &nextSubKey); /* * If not found, return status. */ if (findIdx == TCL_INDEX_NONE) { KEYL_REP_ASSERT (keylIntPtr); return TCL_BREAK; } /* * If we are at the last subkey, delete the entry. */ if (nextSubKey == NULL) { DeleteKeyedListEntry (keylIntPtr, findIdx); Tcl_InvalidateStringRep (keylPtr); KEYL_REP_ASSERT (keylIntPtr); return TCL_OK; } /* * If we are not at the last subkey, recurse down. If the entry is * deleted and the sub-keyed list is empty, delete it as well. Must * invalidate string, as it caches all representations below it. */ DupSharedKeyListChild (keylIntPtr, findIdx); status = TclX_KeyedListDelete (interp, keylIntPtr->entries [findIdx].valuePtr, nextSubKey); if (status == TCL_OK) { subKeylIntPtr = (keylIntObj_t *) keylIntPtr->entries [findIdx].valuePtr->internalRep.twoPtrValue.ptr1; if (subKeylIntPtr->numEntries == 0) { DeleteKeyedListEntry (keylIntPtr, findIdx); } Tcl_InvalidateStringRep (keylPtr); } KEYL_REP_ASSERT (keylIntPtr); return status; } /*----------------------------------------------------------------------------- * TclX_KeyedListGetKeys -- * Retrieve a list of keyed list keys. * * Parameters: * o interp - Error message will be return in result if there is an error. * o keylPtr - Keyed list object to get key from. * o key - The name of the key to get the sub keys for. NULL or empty * to retrieve all top level keys. * o listObjPtrPtr - List object is returned here with key as values. * Returns: * o TCL_OK - If the zero or more key where returned. * o TCL_BREAK - If the key was not found. * o TCL_ERROR - If an error occured. *----------------------------------------------------------------------------- */ int TclX_KeyedListGetKeys( Tcl_Interp *interp, Tcl_Obj *keylPtr, const char *key, Tcl_Obj **listObjPtrPtr ) { keylIntObj_t *keylIntPtr; Tcl_Obj *nameObjPtr, *listObjPtr; const char *nextSubKey; size_t idx, findIdx; if (keylPtr->typePtr != &keyedListType) { if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) { return TCL_ERROR; } } keylIntPtr = (keylIntObj_t *)keylPtr->internalRep.twoPtrValue.ptr1; /* * If key is not NULL or empty, then recurse down until we go past * the end of all of the elements of the key. */ if ((key != NULL) && (key [0] != '\0')) { findIdx = FindKeyedListEntry (keylIntPtr, key, NULL, &nextSubKey); if (findIdx == TCL_INDEX_NONE) { TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); return TCL_BREAK; } TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); return TclX_KeyedListGetKeys (interp, keylIntPtr->entries [findIdx].valuePtr, nextSubKey, listObjPtrPtr); } /* * Reached the end of the full key, return all keys at this level. */ listObjPtr = Tcl_NewListObj (0, NULL); for (idx = 0; idx < keylIntPtr->numEntries; idx++) { nameObjPtr = Tcl_NewStringObj (keylIntPtr->entries [idx].key, TCL_INDEX_NONE); if (Tcl_ListObjAppendElement (interp, listObjPtr, nameObjPtr) != TCL_OK) { Tcl_DecrRefCount (nameObjPtr); Tcl_DecrRefCount (listObjPtr); return TCL_ERROR; } } *listObjPtrPtr = listObjPtr; TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); return TCL_OK; } /*----------------------------------------------------------------------------- * Tcl_KeylgetObjCmd -- * Implements the TCL keylget command: * keylget listvar ?key? ?retvar | {}? *----------------------------------------------------------------------------- */ static int Tcl_KeylgetObjCmd( void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { Tcl_Obj *keylPtr, *valuePtr; const char *key; int status; if ((objc < 2) || (objc > 4)) { return TclX_WrongArgs (interp, objv [0], "listvar ?key? ?retvar | {}?"); } /* * Handle request for list of keys, use keylkeys command. */ if (objc == 2) return Tcl_KeylkeysObjCmd (clientData, interp, objc, objv); keylPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (keylPtr == NULL) { return TCL_ERROR; } /* * Handle retrieving a value for a specified key. */ key = Tcl_GetString(objv[2]); if (ValidateKey(interp, key, objv[2]->length, 1) == TCL_ERROR) { return TCL_ERROR; } status = TclX_KeyedListGet (interp, keylPtr, key, &valuePtr); if (status == TCL_ERROR) return TCL_ERROR; /* * Handle key not found. */ if (status == TCL_BREAK) { if (objc == 3) { TclX_AppendObjResult (interp, "key \"", key, "\" not found in keyed list", (char *) NULL); return TCL_ERROR; } else { Tcl_ResetResult(interp); Tcl_SetIntObj(Tcl_GetObjResult (interp), 0); return TCL_OK; } } /* * No variable specified, so return value in the result. */ if (objc == 3) { Tcl_SetObjResult (interp, valuePtr); return TCL_OK; } /* * Variable (or empty variable name) specified. */ if (!TclX_IsNullObj(objv [3])) { if (Tcl_ObjSetVar2(interp, objv[3], NULL, valuePtr, TCL_LEAVE_ERR_MSG) == NULL) return TCL_ERROR; } Tcl_ResetResult(interp); Tcl_SetIntObj(Tcl_GetObjResult (interp), 1); return TCL_OK; } /*----------------------------------------------------------------------------- * Tcl_KeylsetObjCmd -- * Implements the TCL keylset command: * keylset listvar key value ?key value...? *----------------------------------------------------------------------------- */ static int Tcl_KeylsetObjCmd( void *dummy, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { Tcl_Obj *keylVarPtr, *newVarObj; const char *key; Tcl_Size idx; (void)dummy; if ((objc < 4) || ((objc % 2) != 0)) { return TclX_WrongArgs (interp, objv [0], "listvar key value ?key value...?"); } /* * Get the variable that we are going to update. If the var doesn't exist, * create it. If it is shared by more than being a variable, duplicated * it. */ keylVarPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if ((keylVarPtr == NULL) || (Tcl_IsShared (keylVarPtr))) { if (keylVarPtr == NULL) { keylVarPtr = TclX_NewKeyedListObj (); } else { keylVarPtr = Tcl_DuplicateObj (keylVarPtr); } newVarObj = keylVarPtr; } else { newVarObj = NULL; } for (idx = 2; idx < objc; idx += 2) { key = Tcl_GetString(objv[idx]); if (ValidateKey(interp, key, objv[idx]->length, 1) == TCL_ERROR) { goto errorExit; } if (TclX_KeyedListSet (interp, keylVarPtr, key, objv [idx+1]) != TCL_OK) { goto errorExit; } } if (Tcl_ObjSetVar2(interp, objv[1], NULL, keylVarPtr, TCL_LEAVE_ERR_MSG) == NULL) { goto errorExit; } return TCL_OK; errorExit: if (newVarObj != NULL) { Tcl_DecrRefCount (newVarObj); } return TCL_ERROR; } /*----------------------------------------------------------------------------- * Tcl_KeyldelObjCmd -- * Implements the TCL keyldel command: * keyldel listvar key ?key ...? *---------------------------------------------------------------------------- */ static int Tcl_KeyldelObjCmd( void *dummy, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { Tcl_Obj *keylVarPtr, *keylPtr; const char *key; Tcl_Size idx; int status; (void)dummy; if (objc < 3) { return TclX_WrongArgs (interp, objv [0], "listvar key ?key ...?"); } /* * Get the variable that we are going to update. If it is shared by more * than being a variable, duplicated it. */ keylVarPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (keylVarPtr == NULL) { return TCL_ERROR; } if (Tcl_IsShared (keylVarPtr)) { keylPtr = Tcl_DuplicateObj (keylVarPtr); keylVarPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, keylPtr, TCL_LEAVE_ERR_MSG); if (keylVarPtr == NULL) { Tcl_DecrRefCount (keylPtr); return TCL_ERROR; } if (keylVarPtr != keylPtr) { Tcl_DecrRefCount (keylPtr); } } keylPtr = keylVarPtr; for (idx = 2; idx < objc; idx++) { key = Tcl_GetString(objv[idx]); if (ValidateKey(interp, key, objv[idx]->length, 1) == TCL_ERROR) { return TCL_ERROR; } status = TclX_KeyedListDelete (interp, keylPtr, key); switch (status) { case TCL_BREAK: TclX_AppendObjResult (interp, "key not found: \"", key, "\"", (char *) NULL); return TCL_ERROR; case TCL_ERROR: return TCL_ERROR; } } return TCL_OK; } /*----------------------------------------------------------------------------- * Tcl_KeylkeysObjCmd -- * Implements the TCL keylkeys command: * keylkeys listvar ?key? *----------------------------------------------------------------------------- */ static int Tcl_KeylkeysObjCmd( void *dummy, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[] ) { Tcl_Obj *keylPtr, *listObjPtr; const char *key; int status; (void)dummy; if ((objc < 2) || (objc > 3)) { return TclX_WrongArgs(interp, objv [0], "listvar ?key?"); } keylPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (keylPtr == NULL) { return TCL_ERROR; } /* * If key argument is not specified, then objv [2] is NULL or empty, * meaning get top level keys. */ if (objc < 3) { key = NULL; } else { key = Tcl_GetString(objv[2]); if (ValidateKey(interp, key, objv[2]->length, 1) == TCL_ERROR) { return TCL_ERROR; } } status = TclX_KeyedListGetKeys (interp, keylPtr, key, &listObjPtr); switch (status) { case TCL_BREAK: TclX_AppendObjResult (interp, "key not found: \"", key, "\"", (char *) NULL); return TCL_ERROR; case TCL_ERROR: return TCL_ERROR; } Tcl_SetObjResult (interp, listObjPtr); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_KeyedListInit -- * Initialize the keyed list commands for this interpreter. * * Parameters: * o interp - Interpreter to add commands to. *----------------------------------------------------------------------------- */ void TclX_KeyedListInit( Tcl_Interp *interp ) { Tcl_Obj *listobj; listobj = Tcl_NewObj(); listobj = Tcl_NewListObj(1, &listobj); listType = listobj->typePtr; Tcl_DecrRefCount(listobj); if (0) { Tcl_CreateObjCommand2(interp, "keylget", Tcl_KeylgetObjCmd, NULL, NULL); Tcl_CreateObjCommand2(interp, "keylset", Tcl_KeylsetObjCmd, NULL, NULL); Tcl_CreateObjCommand2(interp, "keyldel", Tcl_KeyldelObjCmd, NULL, NULL); Tcl_CreateObjCommand2(interp, "keylkeys", Tcl_KeylkeysObjCmd, NULL, NULL); } } thread3.0.1/generic/tclThreadInt.h0000644003604700454610000001015514726633451015467 0ustar dgp771div/* * -------------------------------------------------------------------------- * tclthreadInt.h -- * * Global internal header file for the thread extension. * * Copyright (c) 2002 ActiveState Corporation. * Copyright (c) 2002 by Zoran Vasiljevic. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * --------------------------------------------------------------------------- */ #ifndef _TCL_THREAD_INT_H_ #define _TCL_THREAD_INT_H_ #include "tclThread.h" #include /* For strtoul */ #include /* For memset and friends */ #include /* For va_list */ /* * MSVC 8.0 started to mark many standard C library functions depreciated * including the *printf family and others. Tell it to shut up. * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) */ #if defined(_MSC_VER) # pragma warning(disable:4090) /* see: https://developercommunity.visualstudio.com/t/c-compiler-incorrect-propagation-of-const-qualifie/390711 */ # pragma warning(disable:4146) # pragma warning(disable:4244) # if _MSC_VER >= 1400 # pragma warning(disable:4267) # pragma warning(disable:4996) # endif #endif /* * Used to tag functions that are only to be visible within the module being * built and not outside it (where this is supported by the linker). */ #ifndef MODULE_SCOPE # ifdef __cplusplus # define MODULE_SCOPE extern "C" # else # define MODULE_SCOPE extern # endif #endif #if defined(_WIN32) && defined(_MSC_VER) && _MSC_VER < 1900 # define snprintf _snprintf #endif /* * For linking against NaviServer/AOLserver require V4 at least */ #ifdef NS_AOLSERVER # include # if !defined(NS_MAJOR_VERSION) || NS_MAJOR_VERSION < 4 # error "unsupported NaviServer/AOLserver version" # endif #endif #if (TCL_MAJOR_VERSION == 8) && defined(USE_TCL_STUBS) #undef Tcl_Free #define Tcl_Free(p) tclStubsPtr->tcl_Free((void *)(p)) #undef Tcl_Realloc #define Tcl_Realloc(p,m) tclStubsPtr->tcl_Realloc((void *)(p),(m)) #endif #ifndef JOIN # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif #ifndef TCL_UNUSED # if defined(__cplusplus) # define TCL_UNUSED(T) T # elif defined(__GNUC__) && (__GNUC__ > 2) # define TCL_UNUSED(T) T JOIN(dummy, __LINE__) __attribute__((unused)) # else # define TCL_UNUSED(T) T JOIN(dummy, __LINE__) # endif #endif /* * Allow for some command names customization. * Only thread:: and tpool:: are handled here. * Shared variable commands are more complicated. * Look into the threadSvCmd.h for more info. */ #define THREAD_CMD_PREFIX "thread::" #define TPOOL_CMD_PREFIX "tpool::" /* * Exported from threadSvCmd.c file. */ MODULE_SCOPE const char *SvInit(Tcl_Interp *interp); /* * Exported from threadSpCmd.c file. */ MODULE_SCOPE const char *SpInit(Tcl_Interp *interp); /* * Exported from threadPoolCmd.c file. */ MODULE_SCOPE const char *TpoolInit(Tcl_Interp *interp); /* * Macros for splicing in/out of linked lists */ #define SpliceIn(a,b) \ (a)->nextPtr = (b); \ if ((b) != NULL) \ (b)->prevPtr = (a); \ (a)->prevPtr = NULL, (b) = (a) #define SpliceOut(a,b) \ if ((a)->prevPtr != NULL) \ (a)->prevPtr->nextPtr = (a)->nextPtr; \ else \ (b) = (a)->nextPtr; \ if ((a)->nextPtr != NULL) \ (a)->nextPtr->prevPtr = (a)->prevPtr /* * Utility macros */ #define TCL_CMD(a,b,c) \ if (Tcl_CreateObjCommand2((a),(b),(c),NULL, NULL) == NULL) \ return NULL; #define OPT_CMP(a,b) \ ((a) && (b) && ((a)[0]==(b)[0]) && ((a)[1]==(b)[1]) && (!strcmp((a),(b)))) #ifndef TCL_TSD_INIT #define TCL_TSD_INIT(keyPtr) \ (ThreadSpecificData*)Tcl_GetThreadData((keyPtr),sizeof(ThreadSpecificData)) #endif /* * Structure to pass to NsThread_Init. This holds the module * and virtual server name for proper interp initializations. */ typedef struct { char *modname; char *server; } NsThreadInterpData; #endif /* _TCL_THREAD_INT_H_ */ thread3.0.1/generic/tclThread.h0000644003604700454610000000146514726633451015020 0ustar dgp771div/* * -------------------------------------------------------------------------- * tclthread.h -- * * Global header file for the thread extension. * * Copyright (c) 2002 ActiveState Corporation. * Copyright (c) 2002 by Zoran Vasiljevic. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * --------------------------------------------------------------------------- */ /* * Thread extension version numbers are not stored here * because this isn't a public export file. */ #ifndef _TCL_THREAD_H_ #define _TCL_THREAD_H_ #include /* * Exported from threadCmd.c file. */ #ifdef __cplusplus extern "C" { #endif DLLEXPORT int Thread_Init(Tcl_Interp *interp); #ifdef __cplusplus } #endif #endif /* _TCL_THREAD_H_ */ thread3.0.1/generic/psLmdb.h0000644003604700454610000000100714726633451014317 0ustar dgp771div/* * psLmdb.h -- * * See the file "license.txt" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * --------------------------------------------------------------------------- */ #ifndef _PSLMDB_H_ #define _PSLMDB_H_ void Sv_RegisterLmdbStore(); #endif /* _PSLMDB_H_ */ /* EOF $RCSfile */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/psLmdb.c0000644003604700454610000002606214726633451014322 0ustar dgp771div/* * This file implements wrappers for persistent lmdb storage for the * shared variable arrays. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * ---------------------------------------------------------------------------- */ #ifdef HAVE_LMDB #include "threadSvCmd.h" #include /* * Structure keeping the lmdb environment context */ typedef struct { MDB_env * env; // Environment MDB_txn * txn; // Last active read transaction MDB_cursor * cur; // Cursor used for ps_lmdb_first and ps_lmdb_next MDB_dbi dbi; // Open database (default db) int err; // Last error (used in ps_lmdb_geterr) } * LmdbCtx; /* * Transaction and DB open mode */ enum LmdbOpenMode { LmdbRead, LmdbWrite }; // Initialize or renew a transaction. static void LmdbTxnGet(LmdbCtx ctx, enum LmdbOpenMode mode); // Commit a transaction. static void LmdbTxnCommit(LmdbCtx ctx); // Abort a transaction static void LmdbTxnAbort(LmdbCtx ctx); void LmdbTxnGet(LmdbCtx ctx, enum LmdbOpenMode mode) { // Read transactions are reused, if possible if (ctx->txn && mode == LmdbRead) { ctx->err = mdb_txn_renew(ctx->txn); if (ctx->err) { ctx->txn = NULL; } } else if (ctx->txn && mode == LmdbWrite) { LmdbTxnAbort(ctx); } if (ctx->txn == NULL) { ctx->err = mdb_txn_begin(ctx->env, NULL, 0, &ctx->txn); } if (ctx->err) { ctx->txn = NULL; return; } // Given the setup above, and the arguments given, this won't fail. mdb_dbi_open(ctx->txn, NULL, 0, &ctx->dbi); } void LmdbTxnCommit(LmdbCtx ctx) { ctx->err = mdb_txn_commit(ctx->txn); ctx->txn = NULL; } void LmdbTxnAbort(LmdbCtx ctx) { mdb_txn_abort(ctx->txn); ctx->txn = NULL; } /* * Functions implementing the persistent store interface */ static ps_open_proc ps_lmdb_open; static ps_close_proc ps_lmdb_close; static ps_get_proc ps_lmdb_get; static ps_put_proc ps_lmdb_put; static ps_first_proc ps_lmdb_first; static ps_next_proc ps_lmdb_next; static ps_delete_proc ps_lmdb_delete; static ps_free_proc ps_lmdb_free; static ps_geterr_proc ps_lmdb_geterr; /* * This structure collects all the various pointers * to the functions implementing the lmdb store. */ const PsStore LmdbStore = { "lmdb", NULL, ps_lmdb_open, ps_lmdb_get, ps_lmdb_put, ps_lmdb_first, ps_lmdb_next, ps_lmdb_delete, ps_lmdb_close, ps_lmdb_free, ps_lmdb_geterr, NULL }; /* *----------------------------------------------------------------------------- * * Sv_RegisterLmdbStore -- * * Register the lmdb store with shared variable implementation. * * Results: * None. * * Side effects: * None. * *----------------------------------------------------------------------------- */ void Sv_RegisterLmdbStore(void) { Sv_RegisterPsStore(&LmdbStore); } /* *----------------------------------------------------------------------------- * * ps_lmdb_open -- * * Opens the lmdb-based persistent storage. * * Results: * Opaque handle for LmdbCtx. * * Side effects: * The lmdb file might be created if not found. * *----------------------------------------------------------------------------- */ static void * ps_lmdb_open( const char *path) { LmdbCtx ctx; char *ext; Tcl_DString toext; ctx = (LmdbCtx)Tcl_Alloc(sizeof(*ctx)); if (ctx == NULL) { return NULL; } ctx->env = NULL; ctx->txn = NULL; ctx->cur = NULL; ctx->dbi = 0; ctx->err = mdb_env_create(&ctx->env); if (ctx->err) { Tcl_Free(ctx); return NULL; } Tcl_DStringInit(&toext); ext = Tcl_UtfToExternalDString(NULL, path, strlen(path), &toext); ctx->err = mdb_env_open(ctx->env, ext, MDB_NOSUBDIR|MDB_NOLOCK, 0666); Tcl_DStringFree(&toext); if (ctx->err) { Tcl_Free(ctx); return NULL; } return ctx; } /* *----------------------------------------------------------------------------- * * ps_lmdb_close -- * * Closes the lmdb-based persistent storage. * * Results: * 0 - ok * * Side effects: * None. * *----------------------------------------------------------------------------- */ static int ps_lmdb_close( void *handle) { LmdbCtx ctx = (LmdbCtx)handle; if (ctx->cur) { mdb_cursor_close(ctx->cur); } if (ctx->txn) { LmdbTxnAbort(ctx); } mdb_env_close(ctx->env); Tcl_Free(ctx); return 0; } /* *----------------------------------------------------------------------------- * * ps_lmdb_get -- * * Retrieves data for the key from the lmdb storage. * * Results: * 1 - no such key * 0 - ok * * Side effects: * Data returned must be copied, then psFree must be called. * *----------------------------------------------------------------------------- */ static int ps_lmdb_get( void *handle, const char *keyptr, char **dataptrptr, Tcl_Size *lenptr) { LmdbCtx ctx = (LmdbCtx)handle; MDB_val key, data; LmdbTxnGet(ctx, LmdbRead); if (ctx->err) { return 1; } key.mv_data = (void *)keyptr; key.mv_size = strlen(keyptr) + 1; ctx->err = mdb_get(ctx->txn, ctx->dbi, &key, &data); if (ctx->err) { mdb_txn_reset(ctx->txn); return 1; } *dataptrptr = (char *)data.mv_data; *lenptr = data.mv_size; /* * Transaction is left open at this point, so that the caller can get ahold * of the data and make a copy of it. Afterwards, it will call ps_lmdb_free * to free the data, and we'll catch the chance to reset the transaction * there. */ return 0; } /* *----------------------------------------------------------------------------- * * ps_lmdb_first -- * * Starts the iterator over the lmdb file and returns the first record. * * Results: * 1 - no more records in the iterator * 0 - ok * * Side effects: * Data returned must be copied, then psFree must be called. * *----------------------------------------------------------------------------- */ static int ps_lmdb_first( void *handle, char **keyptrptr, char **dataptrptr, Tcl_Size *lenptr) { LmdbCtx ctx = (LmdbCtx)handle; MDB_val key, data; LmdbTxnGet(ctx, LmdbRead); if (ctx->err) { return 1; } ctx->err = mdb_cursor_open(ctx->txn, ctx->dbi, &ctx->cur); if (ctx->err) { return 1; } ctx->err = mdb_cursor_get(ctx->cur, &key, &data, MDB_FIRST); if (ctx->err) { mdb_txn_reset(ctx->txn); mdb_cursor_close(ctx->cur); ctx->cur = NULL; return 1; } *dataptrptr = (char *)data.mv_data; *lenptr = data.mv_size; *keyptrptr = (char *)key.mv_data; return 0; } /* *----------------------------------------------------------------------------- * * ps_lmdb_next -- * * Uses the iterator over the lmdb file and returns the next record. * * Results: * 1 - no more records in the iterator * 0 - ok * * Side effects: * Data returned must be copied, then psFree must be called. * *----------------------------------------------------------------------------- */ static int ps_lmdb_next( void *handle, char **keyptrptr, char **dataptrptr, Tcl_Size *lenptr) { LmdbCtx ctx = (LmdbCtx)handle; MDB_val key, data; ctx->err = mdb_cursor_get(ctx->cur, &key, &data, MDB_NEXT); if (ctx->err) { mdb_txn_reset(ctx->txn); mdb_cursor_close(ctx->cur); ctx->cur = NULL; return 1; } *dataptrptr = (char *)data.mv_data; *lenptr = data.mv_size; *keyptrptr = (char *)key.mv_data; return 0; } /* *----------------------------------------------------------------------------- * * ps_lmdb_put -- * * Stores used data bound to a key in lmdb storage. * * Results: * 0 - ok * -1 - error; use ps_lmdb_geterr to retrieve the error message * * Side effects: * If the key is already associated with some user data, this will * be replaced by the new data chunk. * *----------------------------------------------------------------------------- */ static int ps_lmdb_put( void *handle, const char *keyptr, char *dataptr, Tcl_Size len) { LmdbCtx ctx = (LmdbCtx)handle; MDB_val key, data; LmdbTxnGet(ctx, LmdbWrite); if (ctx->err) { return -1; } key.mv_data = (void*)keyptr; key.mv_size = strlen(keyptr) + 1; data.mv_data = dataptr; data.mv_size = len; ctx->err = mdb_put(ctx->txn, ctx->dbi, &key, &data, 0); if (ctx->err) { LmdbTxnAbort(ctx); } else { LmdbTxnCommit(ctx); } return ctx->err ? -1 : 0; } /* *----------------------------------------------------------------------------- * * ps_lmdb_delete -- * * Deletes the key and associated data from the lmdb storage. * * Results: * 0 - ok * -1 - error; use ps_lmdb_geterr to retrieve the error message * * Side effects: * If the key is already associated with some user data, this will * be replaced by the new data chunk. * *----------------------------------------------------------------------------- */ static int ps_lmdb_delete( void *handle, const char *keyptr) { LmdbCtx ctx = (LmdbCtx)handle; MDB_val key; LmdbTxnGet(ctx, LmdbWrite); if (ctx->err) { return -1; } key.mv_data = (void*)keyptr; key.mv_size = strlen(keyptr) + 1; ctx->err = mdb_del(ctx->txn, ctx->dbi, &key, NULL); if (ctx->err) { LmdbTxnAbort(ctx); } else { LmdbTxnCommit(ctx); } ctx->txn = NULL; return ctx->err ? -1 : 0; } /* *----------------------------------------------------------------------------- * * ps_lmdb_free -- * * This function is called to free data returned by the persistent store * after calls to psFirst, psNext, or psGet. Lmdb doesn't need to free any * data, as the data returned is owned by lmdb. On the other hand, this * method is required to reset the read transaction. This is done only * when iteration is over (ctx->cur == NULL). * * Results: * None. * * Side effects: * Memory gets reclaimed. * *----------------------------------------------------------------------------- */ static void ps_lmdb_free( void *handle, TCL_UNUSED(void *)) { LmdbCtx ctx = (LmdbCtx)handle; if (ctx->cur == NULL) { mdb_txn_reset(ctx->txn); } } /* *----------------------------------------------------------------------------- * * ps_lmdb_geterr -- * * Retrieves the textual representation of the error caused * by the last lmdb command. * * Results: * Pointer to the string message. * * Side effects: * None. * *----------------------------------------------------------------------------- */ static const char* ps_lmdb_geterr( void *handle) { LmdbCtx ctx = (LmdbCtx)handle; return mdb_strerror(ctx->err); } #endif /* HAVE_LMDB */ /* EOF $RCSfile*/ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/psGdbm.h0000644003604700454610000000100714726633451014312 0ustar dgp771div/* * psGdbm.h -- * * See the file "license.txt" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * --------------------------------------------------------------------------- */ #ifndef _PSGDBM_H_ #define _PSGDBM_H_ void Sv_RegisterGdbmStore(); #endif /* _PSGDBM_H_ */ /* EOF $RCSfile */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/generic/psGdbm.c0000644003604700454610000002060014726633451014305 0ustar dgp771div/* * This file implements wrappers for persistent gdbm storage for the * shared variable arrays. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * ---------------------------------------------------------------------------- */ #ifdef HAVE_GDBM #include "threadSvCmd.h" #include #include /* For free() */ /* * Functions implementing the persistent store interface */ static ps_open_proc ps_gdbm_open; static ps_close_proc ps_gdbm_close; static ps_get_proc ps_gdbm_get; static ps_put_proc ps_gdbm_put; static ps_first_proc ps_gdbm_first; static ps_next_proc ps_gdbm_next; static ps_delete_proc ps_gdbm_delete; static ps_free_proc ps_gdbm_free; static ps_geterr_proc ps_gdbm_geterr; /* * This structure collects all the various pointers * to the functions implementing the gdbm store. */ const PsStore GdbmStore = { "gdbm", NULL, ps_gdbm_open, ps_gdbm_get, ps_gdbm_put, ps_gdbm_first, ps_gdbm_next, ps_gdbm_delete, ps_gdbm_close, ps_gdbm_free, ps_gdbm_geterr, NULL }; /* *----------------------------------------------------------------------------- * * Sv_RegisterGdbmStore -- * * Register the gdbm store with shared variable implementation. * * Results: * None. * * Side effects: * None. * *----------------------------------------------------------------------------- */ void Sv_RegisterGdbmStore(void) { Sv_RegisterPsStore(&GdbmStore); } /* *----------------------------------------------------------------------------- * * ps_gdbm_open -- * * Opens the dbm-based persistent storage. * * Results: * Opaque handle of the opened dbm storage. * * Side effects: * The gdbm file might be created if not found. * *----------------------------------------------------------------------------- */ static void * ps_gdbm_open( const char *path) { GDBM_FILE dbf; char *ext; Tcl_DString toext; Tcl_DStringInit(&toext); ext = Tcl_UtfToExternalDString(NULL, path, strlen(path), &toext); dbf = gdbm_open(ext, 512, GDBM_WRCREAT|GDBM_SYNC|GDBM_NOLOCK, 0666, NULL); Tcl_DStringFree(&toext); return dbf; } /* *----------------------------------------------------------------------------- * * ps_gdbm_close -- * * Closes the gdbm-based persistent storage. * * Results: * 0 - ok * * Side effects: * None. * *----------------------------------------------------------------------------- */ static int ps_gdbm_close( void *handle) { gdbm_close((GDBM_FILE)handle); return 0; } /* *----------------------------------------------------------------------------- * * ps_gdbm_get -- * * Retrieves data for the key from the dbm storage. * * Results: * 1 - no such key * 0 - ok * * Side effects: * Data returned must be freed by the caller. * *----------------------------------------------------------------------------- */ static int ps_gdbm_get( void *handle, const char *key, char **dataptrptr, Tcl_Size *lenptr) { GDBM_FILE dbf = (GDBM_FILE)handle; datum drec, dkey; dkey.dptr = (char*)key; dkey.dsize = strlen(key) + 1; drec = gdbm_fetch(dbf, dkey); if (drec.dptr == NULL) { return 1; } *dataptrptr = drec.dptr; *lenptr = drec.dsize; return 0; } /* *----------------------------------------------------------------------------- * * ps_gdbm_first -- * * Starts the iterator over the dbm file and returns the first record. * * Results: * 1 - no more records in the iterator * 0 - ok * * Side effects: * Data returned must be freed by the caller. * *----------------------------------------------------------------------------- */ static int ps_gdbm_first( void *handle, char **keyptrptr, char **dataptrptr, Tcl_Size *lenptr) { GDBM_FILE dbf = (GDBM_FILE)handle; datum drec, dkey; dkey = gdbm_firstkey(dbf); if (dkey.dptr == NULL) { return 1; } drec = gdbm_fetch(dbf, dkey); if (drec.dptr == NULL) { return 1; } *dataptrptr = drec.dptr; *lenptr = drec.dsize; *keyptrptr = dkey.dptr; return 0; } /* *----------------------------------------------------------------------------- * * ps_gdbm_next -- * * Uses the iterator over the dbm file and returns the next record. * * Results: * 1 - no more records in the iterator * 0 - ok * * Side effects: * Data returned must be freed by the caller. * *----------------------------------------------------------------------------- */ static int ps_gdbm_next( void *handle, char **keyptrptr, char **dataptrptr, Tcl_Size *lenptr) { GDBM_FILE dbf = (GDBM_FILE)handle; datum drec, dkey, dnext; dkey.dptr = *keyptrptr; dkey.dsize = strlen(*keyptrptr) + 1; dnext = gdbm_nextkey(dbf, dkey); free(*keyptrptr), *keyptrptr = NULL; if (dnext.dptr == NULL) { return 1; } drec = gdbm_fetch(dbf, dnext); if (drec.dptr == NULL) { return 1; } *dataptrptr = drec.dptr; *lenptr = drec.dsize; *keyptrptr = dnext.dptr; return 0; } /* *----------------------------------------------------------------------------- * * ps_gdbm_put -- * * Stores used data bound to a key in dbm storage. * * Results: * 0 - ok * -1 - error; use ps_dbm_geterr to retrieve the error message * * Side effects: * If the key is already associated with some user data, this will * be replaced by the new data chunk. * *----------------------------------------------------------------------------- */ static int ps_gdbm_put( void *handle, const char *key, char *dataptr, Tcl_Size len) { GDBM_FILE dbf = (GDBM_FILE)handle; datum drec, dkey; int ret; dkey.dptr = (char*)key; dkey.dsize = strlen(key) + 1; drec.dptr = dataptr; drec.dsize = len; ret = gdbm_store(dbf, dkey, drec, GDBM_REPLACE); if (ret == -1) { return -1; } return 0; } /* *----------------------------------------------------------------------------- * * ps_gdbm_delete -- * * Deletes the key and associated data from the dbm storage. * * Results: * 0 - ok * -1 - error; use ps_dbm_geterr to retrieve the error message * * Side effects: * If the key is already associated with some user data, this will * be replaced by the new data chunk. * *----------------------------------------------------------------------------- */ static int ps_gdbm_delete( void *handle, const char *key) { GDBM_FILE dbf = (GDBM_FILE)handle; datum dkey; int ret; dkey.dptr = (char*)key; dkey.dsize = strlen(key) + 1; ret = gdbm_delete(dbf, dkey); if (ret == -1) { return -1; } return 0; } /* *----------------------------------------------------------------------------- * * ps_gdbm_free -- * * Frees memory allocated by the gdbm implementation. * * Results: * None. * * Side effects: * Memory gets reclaimed. * *----------------------------------------------------------------------------- */ static void ps_gdbm_free( TCL_UNUSED(void *), void *data) { free(data); } /* *----------------------------------------------------------------------------- * * ps_gdbm_geterr -- * * Retrieves the textual representation of the error caused * by the last dbm command. * * Results: * Pointer to the strimg message. * * Side effects: * None. * *----------------------------------------------------------------------------- */ static const char* ps_gdbm_geterr( TCL_UNUSED(void *)) { /* * The problem with gdbm interface is that it uses the global * gdbm_errno variable which is not per-thread nor mutex * protected. This variable is used to reference array of gdbm * error text strings. It is very dangerous to use this in the * MT-program without proper locking. For this kind of app * we should not be concerned with that, since all ps_gdbm_xxx * operations are performed under shared variable lock anyway. */ return gdbm_strerror(gdbm_errno); } #endif /* HAVE_GDBM */ /* EOF $RCSfile*/ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/doc/0000755003604700454610000000000014731057541012054 5ustar dgp771divthread3.0.1/doc/html/0000755003604700454610000000000014731057541013020 5ustar dgp771divthread3.0.1/doc/html/ttrace.html0000644003604700454610000003656614726633451015214 0ustar dgp771div ttrace - Tcl Threading

ttrace(n) 3.0 "Tcl Threading"

Name

ttrace - Trace-based interpreter initialization

Description

This package creates a framework for on-demand replication of the interpreter state across threads in an multithreading application. It relies on the mechanics of Tcl command tracing and the Tcl unknown command and mechanism.

The package requires Tcl threading extension but can be alternatively used stand-alone within the AOLserver, a scalable webserver from America Online.

In a nutshell, a short sample illustrating the usage of the ttrace with the Tcl threading extension:

    % package require ttrace
    3.0.1
    % set t1 [thread::create {package require ttrace; thread::wait}]
    tid0x1802800
    % ttrace::eval {proc test args {return test-[thread::id]}}
    % thread::send $t1 test
    test-tid0x1802800
    % set t2 [thread::create {package require ttrace; thread::wait}]
    tid0x1804000
    % thread::send $t2 test
    test-tid0x1804000

As seen from above, the ttrace::eval and ttrace::update commands are used to create a thread-wide definition of a simple Tcl procedure and replicate that definition to all, already existing or later created, threads.

USER COMMANDS

This section describes user-level commands. Those commands can be used by script writers to control the execution of the tracing framework.

ttrace::eval arg ?arg ...?

This command concatenates given arguments and evaluates the resulting Tcl command with trace framework enabled. If the command execution was ok, it takes necessary steps to automatically propagate the trace epoch change to all threads in the application. For AOLserver, only newly created threads actually receive the epoch change. For the Tcl threading extension, all threads created by the extension are automatically updated. If the command execution resulted in Tcl error, no state propagation takes place.

This is the most important user-level command of the package as it wraps most of the commands described below. This greatly simplifies things, because user need to learn just this (one) command in order to effectively use the package. Other commands, as described below, are included mostly for the sake of completeness.

ttrace::enable

Activates all registered callbacks in the framework and starts a new trace epoch. The trace epoch encapsulates all changes done to the interpreter during the time traces are activated.

ttrace::disable

Deactivates all registered callbacks in the framework and closes the current trace epoch.

ttrace::cleanup

Used to clean-up all on-demand loaded resources in the interpreter. It effectively brings Tcl interpreter to its pristine state.

ttrace::update ?epoch?

Used to refresh the state of the interpreter to match the optional trace ?epoch?. If the optional ?epoch? is not given, it takes the most recent trace epoch.

ttrace::getscript

Returns a synthesized Tcl script which may be sourced in any interpreter. This script sets the stage for the Tcl unknown command so it can load traced resources from the in-memory database. Normally, this command is automatically invoked by other higher-level commands like ttrace::eval and ttrace::update.

CALLBACK COMMANDS

A word upfront: the package already includes callbacks for tracing following Tcl commands: proc, namespace, variable, load, and rename. Additionally, a set of callbacks for tracing resources (object, classes) for the XOTcl v1.3.8+, an OO-extension to Tcl, is also provided. This gives a solid base for solving most of the real-life needs and serves as an example for people wanting to customize the package to cover their specific needs.

Below, you can find commands for registering callbacks in the framework and for writing callback scripts. These callbacks are invoked by the framework in order to gather interpreter state changes, build in-memory database, perform custom-cleanups and various other tasks.

ttrace::atenable cmd arglist body

Registers Tcl callback to be activated at ttrace::enable. Registered callbacks are activated on FIFO basis. The callback definition includes the name of the callback, cmd, a list of callback arguments, arglist and the body of the callback. Effectively, this actually resembles the call interface of the standard Tcl proc command.

ttrace::atdisable cmd arglist body

Registers Tcl callback to be activated at ttrace::disable. Registered callbacks are activated on FIFO basis. The callback definition includes the name of the callback, cmd, a list of callback arguments, arglist and the body of the callback. Effectively, this actually resembles the call interface of the standard Tcl proc command.

ttrace::addtrace cmd arglist body

Registers Tcl callback to be activated for tracing the Tcl cmd command. The callback definition includes the name of the Tcl command to trace, cmd, a list of callback arguments, arglist and the body of the callback. Effectively, this actually resembles the call interface of the standard Tcl proc command.

ttrace::addscript name body

Registers Tcl callback to be activated for building a Tcl script to be passed to other interpreters. This script is used to set the stage for the Tcl unknown command. Registered callbacks are activated on FIFO basis. The callback definition includes the name of the callback, name and the body of the callback.

ttrace::addresolver cmd arglist body

Registers Tcl callback to be activated by the overloaded Tcl unknown command. Registered callbacks are activated on FIFO basis. This callback is used to resolve the resource and load the resource in the current interpreter.

ttrace::addcleanup body

Registers Tcl callback to be activated by the trace::cleanup. Registered callbacks are activated on FIFO basis.

ttrace::addentry cmd var val

Adds one entry to the named in-memory database.

ttrace::getentry cmd var

Returns the value of the entry from the named in-memory database.

ttrace::getentries cmd ?pattern?

Returns names of all entries from the named in-memory database.

ttrace::delentry cmd

Deletes an entry from the named in-memory database.

ttrace::preload cmd

Registers the Tcl command to be loaded in the interpreter. Commands registered this way will always be the part of the interpreter and not be on-demand loaded by the Tcl unknown command.

DISCUSSION

Common introspective state-replication approaches use a custom Tcl script to introspect the running interpreter and synthesize another Tcl script to replicate this state in some other interpreter. This package, on the contrary, uses Tcl command traces. Command traces are registered on selected Tcl commands, like proc, namespace, load and other standard (and/or user-defined) Tcl commands. When activated, those traces build an in-memory database of created resources. This database is used as a resource repository for the (overloaded) Tcl unknown command which creates the requested resource in the interpreter on demand. This way, users can update just one interpreter (master) in one thread and replicate that interpreter state (or part of it) to other threads/interpreters in the process.

Immediate benefit of such approach is the much smaller memory footprint of the application and much faster thread creation. By not actually loading all necessary procedures (and other resources) in every thread at the thread initialization time, but by deferring this to the time the resource is actually referenced, significant improvements in both memory consumption and thread initialization time can be achieved. Some tests have shown that memory footprint of an multithreading Tcl application went down more than three times and thread startup time was reduced for about 50 times. Note that your mileage may vary. Other benefits include much finer control about what (and when) gets replicated from the master to other Tcl thread/interpreters.

See Also

thread, tpool, tsv

Keywords

command tracing, introspection

thread3.0.1/doc/html/tsv.html0000644003604700454610000006345114726633451014537 0ustar dgp771div tsv - Tcl Threading

tsv(n) 3.0 "Tcl Threading"

Name

tsv - Part of the Tcl threading extension allowing script level manipulation of data shared between threads.

Description

This section describes commands implementing thread shared variables. A thread shared variable is very similar to a Tcl array but in contrast to a Tcl array it is created in shared memory and can be accessed from many threads at the same time. Important feature of thread shared variable is that each access to the variable is internally protected by a mutex so script programmer does not have to take care about locking the variable himself.

Thread shared variables are not bound to any thread explicitly. That means that when a thread which created any of thread shared variables exits, the variable and associated memory is not unset/reclaimed. User has to explicitly unset the variable to reclaim the memory consumed by the variable.

ELEMENT COMMANDS

tsv::names ?pattern?

Returns names of shared variables matching optional ?pattern? or all known variables if pattern is omitted.

tsv::object varname element

Creates object accessor command for the element in the shared variable varname. Using this command, one can apply most of the other shared variable commands as method functions of the element object command. The object command is automatically deleted when the element which this command is pointing to is unset.

    % tsv::set foo bar "A shared string"
    % set string [tsv::object foo bar]
    % $string append " appended"
    => A shared string appended
tsv::set varname element ?value?

Sets the value of the element in the shared variable varname to value and returns the value to caller. The value may be omitted, in which case the command will return the current value of the element. If the element cannot be found, error is triggered.

tsv::get varname element ?namedvar?

Retrieves the value of the element from the shared variable varname. If the optional argument namedvar is given, the value is stored in the named variable. Return value of the command depends of the existence of the optional argument namedvar. If the argument is omitted and the requested element cannot be found in the shared array, the command triggers error. If, however, the optional argument is given on the command line, the command returns true (1) if the element is found or false (0) if the element is not found.

tsv::unset varname ?element?

Unsets the element from the shared variable varname. If the optional element is not given, it deletes the variable.

tsv::exists varname element

Checks whether the element exists in the shared variable varname and returns true (1) if it does or false (0) if it doesn't.

tsv::pop varname element

Returns value of the element in the shared variable varname and unsets the element, all in one atomic operation.

tsv::move varname oldname newname

Renames the element oldname to the newname in the shared variable varname. This effectively performs an get/unset/set sequence of operations but all in one atomic step.

tsv::incr varname element ?count?

Similar to standard Tcl incr command but increments the value of the element in shared variable varname instead of the Tcl variable.

tsv::append varname element value ?value ...?

Similar to standard Tcl append command but appends one or more values to the element in shared variable varname instead of the Tcl variable.

tsv::lock varname arg ?arg ...?

This command concatenates passed arguments and evaluates the resulting script under the internal mutex protection. During the script evaluation, the entire shared variable is locked. For shared variable commands within the script, internal locking is disabled so no deadlock can occur. It is also allowed to unset the shared variable from within the script. The shared variable is automatically created if it did not exists at the time of the first lock operation.

    % tsv::lock foo {
        tsv::lappend foo bar 1
        tsv::lappend foo bar 2
        puts stderr [tsv::set foo bar]
        tsv::unset foo
    }
tsv::handlers

Returns the names of all persistent storage handlers enabled at compile time. See ARRAY COMMANDS for details.

LIST COMMANDS

Those command are similar to the equivalently named Tcl command. The difference is that they operate on elements of shared arrays.

tsv::lappend varname element value ?value ...?

Similar to standard Tcl lappend command but appends one or more values to the element in shared variable varname instead of the Tcl variable.

tsv::linsert varname element index value ?value ...?

Similar to standard Tcl linsert command but inserts one or more values at the index list position in the element in the shared variable varname instead of the Tcl variable.

tsv::lreplace varname element first last ?value ...?

Similar to standard Tcl lreplace command but replaces one or more values between the first and last position in the element of the shared variable varname instead of the Tcl variable.

tsv::llength varname element

Similar to standard Tcl llength command but returns length of the element in the shared variable varname instead of the Tcl variable.

tsv::lindex varname element ?index?

Similar to standard Tcl lindex command but returns the value at the index list position of the element from the shared variable varname instead of the Tcl variable.

tsv::lrange varname element from to

Similar to standard Tcl lrange command but returns values between from and to list positions from the element in the shared variable varname instead of the Tcl variable.

tsv::lsearch varname element ?options? pattern

Similar to standard Tcl lsearch command but searches the element in the shared variable varname instead of the Tcl variable.

tsv::lset varname element index ?index ...? value

Similar to standard Tcl lset command but sets the element in the shared variable varname instead of the Tcl variable.

tsv::lpop varname element ?index?

Similar to the standard Tcl lindex command but in addition to returning, it also splices the value out of the element from the shared variable varname in one atomic operation. In contrast to the Tcl lindex command, this command returns no value to the caller.

tsv::lpush varname element ?index?

This command performs the opposite of the tsv::lpop command. As its counterpart, it returns no value to the caller.

ARRAY COMMANDS

This command supports most of the options of the standard Tcl array command. In addition to those, it allows binding a shared variable to some persistent storage databases. Currently the persistent options supported are the famous GNU Gdbm and LMDB. These options have to be selected during the package compilation time. The implementation provides hooks for defining other persistency layers, if needed.

tsv::array set varname list

Does the same as standard Tcl array set.

tsv::array get varname ?pattern?

Does the same as standard Tcl array get.

tsv::array names varname ?pattern?

Does the same as standard Tcl array names.

tsv::array size varname

Does the same as standard Tcl array size.

tsv::array reset varname list

Does the same as standard Tcl array set but it clears the varname and sets new values from the list atomically.

tsv::array bind varname handle

Binds the varname to the persistent storage handle. The format of the handle is <handler>:<address>, where <handler> is "gdbm" for GNU Gdbm and "lmdb" for LMDB and <address> is the path to the database file.

tsv::array unbind varname

Unbinds the shared array from its bound persistent storage.

tsv::array isbound varname

Returns true (1) if the shared varname is bound to some persistent storage or zero (0) if not.

KEYED LIST COMMANDS

Keyed list commands are borrowed from the TclX package. Keyed lists provide a structured data type built upon standard Tcl lists. This is a functionality similar to structs in the C programming language.

A keyed list is a list in which each element contains a key and value pair. These element pairs are stored as lists themselves, where the key is the first element of the list, and the value is the second. The key-value pairs are referred to as fields. This is an example of a keyed list:

    {{NAME  {Frank  Zappa}} {JOB {musician and composer}}}

Fields may contain subfields; `.' is the separator character. Subfields are actually fields where the value is another keyed list. Thus the following list has the top level fields ID and NAME, and subfields NAME.FIRST and NAME.LAST:

    {ID 106} {NAME {{FIRST Frank} {LAST Zappa}}}

There is no limit to the recursive depth of subfields, allowing one to build complex data structures. Keyed lists are constructed and accessed via a number of commands. All keyed list management commands take the name of the variable containing the keyed list as an argument (i.e. passed by reference), rather than passing the list directly.

tsv::keyldel varname keylist key

Delete the field specified by key from the keyed list keylist in the shared variable varname. This removes both the key and the value from the keyed list.

tsv::keylget varname keylist key ?retvar?

Return the value associated with key from the keyed list keylist in the shared variable varname. If the optional retvar is not specified, then the value will be returned as the result of the command. In this case, if key is not found in the list, an error will result.

If retvar is specified and key is in the list, then the value is returned in the variable retvar and the command returns 1 if the key was present within the list. If key isn't in the list, the command will return 0, and retvar will be left unchanged. If {} is specified for retvar, the value is not returned, allowing the Tcl programmer to determine if a key is present in a keyed list without setting a variable as a side-effect.

tsv::keylkeys varname keylist ?key?

Return the a list of the keys in the keyed list keylist in the shared variable varname. If key is specified, then it is the name of a key field whose subfield keys are to be retrieved.

tsv::keylset varname keylist key value ?key value..?

Set the value associated with key, in the keyed list keylist to value. If the keylist does not exists, it is created. If key is not currently in the list, it will be added. If it already exists, value replaces the existing value. Multiple keywords and values may be specified, if desired.

DISCUSSION

The current implementation of thread shared variables allows for easy and convenient access to data shared between different threads. Internally, the data is stored in Tcl objects and all package commands operate on internal data representation, thus minimizing shimmering and improving performance. Special care has been taken to assure that all object data is properly locked and deep-copied when moving objects between threads.

Due to the internal design of the Tcl core, there is no provision of full integration of shared variables within the Tcl syntax, unfortunately. All access to shared data must be performed with the supplied package commands. Also, variable traces are not supported. But even so, benefits of easy, simple and safe shared data manipulation outweighs imposed limitations.

CREDITS

Thread shared variables are inspired by the nsv interface found in AOLserver, a highly scalable Web server from America Online.

See Also

thread, tpool, ttrace

Keywords

locking, synchronization, thread shared data, threads

thread3.0.1/doc/html/tpool.html0000644003604700454610000004073514726633451015060 0ustar dgp771div tpool - Tcl Threading

tpool(n) 3.0 "Tcl Threading"

Name

tpool - Part of the Tcl threading extension implementing pools of worker threads.

Description

This package creates and manages pools of worker threads. It allows you to post jobs to worker threads and wait for their completion. The threadpool implementation is Tcl event-loop aware. That means that any time a caller is forced to wait for an event (job being completed or a worker thread becoming idle or initialized), the implementation will enter the event loop and allow for servicing of other pending file or timer (or any other supported) events.

COMMANDS

tpool::create ?options?

This command creates new threadpool. It accepts several options as key-value pairs. Options are used to tune some threadpool parameters. The command returns the ID of the newly created threadpool.

Following options are supported:

-minworkers number

Minimum number of worker threads needed for this threadpool instance. During threadpool creation, the implementation will create somany worker threads upfront and will keep at least number of them alive during the lifetime of the threadpool instance. Default value of this parameter is 0 (zero). which means that a newly threadpool will have no worker threads initially. All worker threads will be started on demand by callers running tpool::post command and posting jobs to the job queue.

-maxworkers number

Maximum number of worker threads allowed for this threadpool instance. If a new job is pending and there are no idle worker threads available, the implementation will try to create new worker thread. If the number of available worker threads is lower than the given number, new worker thread will start. The caller will automatically enter the event loop and wait until the worker thread has initialized. If. however, the number of available worker threads is equal to the given number, the caller will enter the event loop and wait for the first worker thread to get idle, thus ready to run the job. Default value of this parameter is 4 (four), which means that the threadpool instance will allow maximum of 4 worker threads running jobs or being idle waiting for new jobs to get posted to the job queue.

-idletime seconds

Time in seconds an idle worker thread waits for the job to get posted to the job queue. If no job arrives during this interval and the time expires, the worker thread will check the number of currently available worker threads and if the number is higher than the number set by the minthreads option, it will exit. If an exitscript has been defined, the exiting worker thread will first run the script and then exit. Errors from the exit script, if any, are ignored.

The idle worker thread is not servicing the event loop. If you, however, put the worker thread into the event loop, by evaluating the vwait or other related Tcl commands, the worker thread will not be in the idle state, hence the idle timer will not be taken into account. Default value for this option is unspecified.

-initcmd script

Sets a Tcl script used to initialize new worker thread. This is usually used to load packages and commands in the worker, set default variables, create namespaces, and such. If the passed script runs into a Tcl error, the worker will not be created and the initiating command (either the tpool::create or tpool::post) will throw error. Default value for this option is unspecified, hence, the Tcl interpreter of the worker thread will contain just the initial set of Tcl commands.

-exitcmd script

Sets a Tcl script run when the idle worker thread exits. This is normally used to cleanup the state of the worker thread, release reserved resources, cleanup memory and such. Default value for this option is unspecified, thus no Tcl script will run on the worker thread exit.

tpool::names

This command returns a list of IDs of threadpools created with the tpool::create command. If no threadpools were found, the command will return empty list.

tpool::post ?-detached? ?-nowait? tpool script

This command sends a script to the target tpool threadpool for execution. The script will be executed in the first available idle worker thread. If there are no idle worker threads available, the command will create new one, enter the event loop and service events until the newly created thread is initialized. If the current number of worker threads is equal to the maximum number of worker threads, as defined during the threadpool creation, the command will enter the event loop and service events while waiting for one of the worker threads to become idle. If the optional ?-nowait? argument is given, the command just places the job in the pool's job queue without waiting for an idle worker or creating a new one, even if the pool would still have room for additional threads.

The command returns the ID of the posted job. This ID is used for subsequent tpool::wait, tpool::get and tpool::cancel commands to wait for and retrieve result of the posted script, or cancel the posted job respectively. If the optional ?-detached? argument is specified, the command will post a detached job. A detached job can not be cancelled or waited upon and is not identified by the job ID.

If the threadpool tpool is not found in the list of active thread pools, the command will throw error. The error will also be triggered if the newly created worker thread fails to initialize.

tpool::wait tpool joblist ?varname?

This command waits for one or many jobs, whose job IDs are given in the joblist to get processed by the worker thread(s). If none of the specified jobs are ready, the command will enter the event loop, service events and wait for the first job to get ready.

The command returns the list of completed job IDs. If the optional variable ?varname? is given, it will be set to the list of jobs in the joblist which are still pending. If the threadpool tpool is not found in the list of active thread pools, the command will throw error.

tpool::cancel tpool joblist ?varname?

This command cancels the previously posted jobs given by the joblist to the pool tpool. Job cancellation succeeds only for job still waiting to be processed. If the job is already being executed by one of the worker threads, the job will not be cancelled. The command returns the list of cancelled job IDs. If the optional variable ?varname? is given, it will be set to the list of jobs in the joblist which were not cancelled. If the threadpool tpool is not found in the list of active thread pools, the command will throw error.

tpool::get tpool job

This command retrieves the result of the previously posted job. Only results of jobs waited upon with the tpool::wait command can be retrieved. If the execution of the script resulted in error, the command will throw the error and update the errorInfo and errorCode variables correspondingly. If the pool tpool is not found in the list of threadpools, the command will throw error. If the job job is not ready for retrieval, because it is currently being executed by the worker thread, the command will throw error.

tpool::preserve tpool

Each call to this command increments the reference counter of the threadpool tpool by one (1). Command returns the value of the reference counter after the increment. By incrementing the reference counter, the caller signalizes that he/she wishes to use the resource for a longer period of time.

tpool::release tpool

Each call to this command decrements the reference counter of the threadpool tpool by one (1).Command returns the value of the reference counter after the decrement. When the reference counter reaches zero (0), the threadpool tpool is marked for termination. You should not reference the threadpool after the tpool::release command returns zero. The tpool handle goes out of scope and should not be used any more. Any following reference to the same threadpool handle will result in Tcl error.

tpool::suspend tpool

Suspends processing work on this queue. All pool workers are paused but additional work can be added to the pool. Note that adding the additional work will not increase the number of workers dynamically as the pool processing is suspended. Number of workers is maintained to the count that was found prior suspending worker activity. If you need to assure certain number of worker threads, use the minworkers option of the tpool::create command.

tpool::resume tpool

Resume processing work on this queue. All paused (suspended) workers are free to get work from the pool. Note that resuming pool operation will just let already created workers to proceed. It will not create additional worker threads to handle the work posted to the pool's work queue.

DISCUSSION

Threadpool is one of the most common threading paradigm when it comes to server applications handling a large number of relatively small tasks. A very simplistic model for building a server application would be to create a new thread each time a request arrives and service the request in the new thread. One of the disadvantages of this approach is that the overhead of creating a new thread for each request is significant; a server that created a new thread for each request would spend more time and consume more system resources in creating and destroying threads than in processing actual user requests. In addition to the overhead of creating and destroying threads, active threads consume system resources. Creating too many threads can cause the system to run out of memory or trash due to excessive memory consumption.

A thread pool offers a solution to both the problem of thread life-cycle overhead and the problem of resource trashing. By reusing threads for multiple tasks, the thread-creation overhead is spread over many tasks. As a bonus, because the thread already exists when a request arrives, the delay introduced by thread creation is eliminated. Thus, the request can be serviced immediately. Furthermore, by properly tuning the number of threads in the thread pool, resource thrashing may also be eliminated by forcing any request to wait until a thread is available to process it.

See Also

thread, tsv, ttrace

Keywords

thread, threadpool

thread3.0.1/doc/html/thread.html0000644003604700454610000010621014726633451015161 0ustar dgp771div thread - Tcl Threading

thread(n) 3.0 "Tcl Threading"

Name

thread - Extension for script access to Tcl threading

Description

The thread extension creates threads that contain Tcl interpreters, and it lets you send scripts to those threads for evaluation. Additionally, it provides script-level access to basic thread synchronization primitives, like mutexes and condition variables.

COMMANDS

This section describes commands for creating and destroying threads and sending scripts to threads for evaluation.

thread::create ?-joinable? ?-preserved? ?script?

This command creates a thread that contains a Tcl interpreter. The Tcl interpreter either evaluates the optional script, if specified, or it waits in the event loop for scripts that arrive via the thread::send command. The result, if any, of the optional script is never returned to the caller. The result of thread::create is the ID of the thread. This is the opaque handle which identifies the newly created thread for all other package commands. The handle of the thread goes out of scope automatically when thread is marked for exit (see the thread::release command below).

If the optional script argument contains the thread::wait command the thread will enter into the event loop. If such command is not found in the script the thread will run the script to the end and exit. In that case, the handle may be safely ignored since it refers to a thread which does not exists any more at the time when the command returns.

Using flag -joinable it is possible to create a joinable thread, i.e. one upon whose exit can be waited upon by using thread::join command. Note that failure to join a thread created with -joinable flag results in resource and memory leaks.

Threads created by the thread::create cannot be destroyed forcefully. Consequently, there is no corresponding thread destroy command. A thread may only be released using the thread::release and if its internal reference count drops to zero, the thread is marked for exit. This kicks the thread out of the event loop servicing and the thread continues to execute commands passed in the script argument, following the thread::wait command. If this was the last command in the script, as usually the case, the thread will exit.

It is possible to create a situation in which it may be impossible to terminate the thread, for example by putting some endless loop after the thread::wait or entering the event loop again by doing an vwait-type of command. In such cases, the thread may never exit. This is considered to be a bad practice and should be avoided if possible. This is best illustrated by the example below:

    # You should never do ...
    set tid [thread::create {
        package require Http
        thread::wait
        vwait forever ; # <-- this!
    }]

The thread created in the above example will never be able to exit. After it has been released with the last matching thread::release call, the thread will jump out of the thread::wait and continue to execute commands following. It will enter vwait command and wait endlessly for events. There is no way one can terminate such thread, so you wouldn't want to do this!

Each newly created has its internal reference counter set to 0 (zero), i.e. it is unreserved. This counter gets incremented by a call to thread::preserve and decremented by a call to thread::release command. These two commands implement simple but effective thread reservation system and offer predictable and controllable thread termination capabilities. It is however possible to create initially preserved threads by using flag -preserved of the thread::create command. Threads created with this flag have the initial value of the reference counter of 1 (one), and are thus initially marked reserved.

thread::preserve ?id?

This command increments the thread reference counter. Each call to this command increments the reference counter by one (1). Command returns the value of the reference counter after the increment. If called with the optional thread id, the command preserves the given thread. Otherwise the current thread is preserved.

With reference counting, one can implement controlled access to a shared Tcl thread. By incrementing the reference counter, the caller signalizes that he/she wishes to use the thread for a longer period of time. By decrementing the counter, caller signalizes that he/she has finished using the thread.

thread::release ?-wait? ?id?

This command decrements the thread reference counter. Each call to this command decrements the reference counter by one (1). If called with the optional thread id, the command releases the given thread. Otherwise, the current thread is released. Command returns the value of the reference counter after the decrement. When the reference counter reaches zero (0), the target thread is marked for termination. You should not reference the thread after the thread::release command returns zero or negative integer. The handle of the thread goes out of scope and should not be used any more. Any following reference to the same thread handle will result in Tcl error.

Optional flag -wait instructs the caller thread to wait for the target thread to exit, if the effect of the command would result in termination of the target thread, i.e. if the return result would be zero (0). Without the flag, the caller thread does not wait for the target thread to exit. Care must be taken when using the -wait, since this may block the caller thread indefinitely. This option has been implemented for some special uses of the extension and is deprecated for regular use. Regular users should create joinable threads by using the -joinable option of the thread::create command and the thread::join to wait for thread to exit.

thread::id

This command returns the ID of the current thread.

thread::errorproc ?procname?

This command sets a handler for errors that occur in scripts sent asynchronously, using the -async flag of the thread::send command, to other threads. If no handler is specified, the current handler is returned. The empty string resets the handler to default (unspecified) value. An uncaught error in a thread causes an error message to be sent to the standard error channel. This default reporting scheme can be changed by registering a procedure which is called to report the error. The procname is called in the interpreter that invoked the thread::errorproc command. The procname is called like this:

    myerrorproc thread_id errorInfo
thread::cancel ?-unwind? id ?result?

This command requires Tcl version 8.6 or higher.

Cancels the script being evaluated in the thread given by the id parameter. Without the -unwind switch the evaluation stack for the interpreter is unwound until an enclosing catch command is found or there are no further invocations of the interpreter left on the call stack. With the -unwind switch the evaluation stack for the interpreter is unwound without regard to any intervening catch command until there are no further invocations of the interpreter left on the call stack. If result is present, it will be used as the error message string; otherwise, a default error message string will be used.

thread::unwind

Use of this command is deprecated in favour of more advanced thread reservation system implemented with thread::preserve and thread::release commands. Support for thread::unwind command will disappear in some future major release of the extension.

This command stops a prior thread::wait command. Execution of the script passed to newly created thread will continue from the thread::wait command. If thread::wait was the last command in the script, the thread will exit. The command returns empty result but may trigger Tcl error with the message "target thread died" in some situations.

thread::exit ?status?

Use of this command is deprecated in favour of more advanced thread reservation system implemented with thread::preserve and thread::release commands. Support for thread::exit command will disappear in some future major release of the extension.

This command forces a thread stuck in the thread::wait command to unconditionally exit. The thread's exit status defaults to 666 and can be specified using the optional status argument. The execution of thread::exit command is guaranteed to leave the program memory in the inconsistent state, produce memory leaks and otherwise affect other subsystem(s) of the Tcl application in an unpredictable manner. The command returns empty result but may trigger Tcl error with the message "target thread died" in some situations.

thread::names

This command returns a list of thread IDs. These are only for threads that have been created via thread::create command. If your application creates other threads at the C level, they are not reported by this command.

thread::exists id

Returns true (1) if thread given by the id parameter exists, false (0) otherwise. This applies only for threads that have been created via thread::create command.

thread::send ?-async? ?-head? id script ?varname?

This command passes a script to another thread and, optionally, waits for the result. If the -async flag is specified, the command does not wait for the result and it returns empty string. The target thread must enter it's event loop in order to receive scripts sent via this command. This is done by default for threads created without a startup script. Threads can enter the event loop explicitly by calling thread::wait or any other relevant Tcl/Tk command, like update, vwait, etc.

Optional varname specifies name of the variable to store the result of the script. Without the -async flag, the command returns the evaluation code, similarly to the standard Tcl catch command. If, however, the -async flag is specified, the command returns immediately and caller can later vwait on ?varname? to get the result of the passed script

    set t1 [thread::create]
    set t2 [thread::create]
    thread::send -async $t1 "set a 1" result
    thread::send -async $t2 "set b 2" result
    for {set i 0} {$i < 2} {incr i} {
        vwait result
    }

In the above example, two threads were fed work and both of them were instructed to signalize the same variable "result" in the calling thread. The caller entered the event loop twice to get both results. Note, however, that the order of the received results may vary, depending on the current system load, type of work done, etc, etc.

Many threads can simultaneously send scripts to the target thread for execution. All of them are entered into the event queue of the target thread and executed on the FIFO basis, intermingled with optional other events pending in the event queue of the target thread. Using the optional ?-head? switch, scripts posted to the thread's event queue can be placed on the head, instead on the tail of the queue, thus being executed in the LIFO fashion.

thread::broadcast script

This command passes a script to all threads created by the package for execution. It does not wait for response from any of the threads.

The sending thread (the one executing the thread::broadcast command) does not send the script to itself.

Each receiving thread is directed to place evaluation of the send script at the head of its event queue, stepping in front of any other events awaiting processing.

thread::wait

This enters the event loop so a thread can receive messages from the thread::send command. This command should only be used within the script passed to the thread::create. It should be the very last command in the script. If this is not the case, the exiting thread will continue executing the script lines past the thread::wait which is usually not what you want and/or expect.

    set t1 [thread::create {
        #
        # Do some initialization work here
        #
        thread::wait ; # Enter the event loop
    }]
thread::eval ?-lock mutex? arg ?arg ...?

This command concatenates passed arguments and evaluates the resulting script under the mutex protection. If no mutex is specified by using the ?-lock mutex? optional argument, the internal static mutex is used.

thread::join id

This command waits for the thread with ID id to exit and then returns it's exit code. Errors will be returned for threads which are not joinable or already waited upon by another thread. Upon the join the handle of the thread has gone out of scope and should not be used any more.

thread::configure id ?option? ?value? ?...?

This command configures various low-level aspects of the thread with ID id in the similar way as the standard Tcl command fconfigure configures some Tcl channel options. Options currently supported are: -eventmark and -unwindonerror.

When -eventmark is provided with a value greater than 0 (zero), that value is the maximum number of asynchronously posted scripts that may be pending for the thread. thread::send -async blocks until the number of pending scripts in the event loop drops below the -eventmark value.

When -unwindonerror is provided with a value of true, an error result in a script causes the thread to unwind, making it unavailable to evaluate additional scripts.

thread::transfer id channel

This moves the specified channel from the current thread and interpreter to the main interpreter of the thread with the given id. After the move the current interpreter has no access to the channel any more, but the main interpreter of the target thread will be able to use it from now on. The command waits until the other thread has incorporated the channel. Because of this it is possible to deadlock the participating threads by commanding the other through a synchronous thread::send to transfer a channel to us. This easily extends into longer loops of threads waiting for each other. Other restrictions: the channel in question must not be shared among multiple interpreters running in the sending thread. This automatically excludes the special channels for standard input, output and error.

Due to the internal Tcl core implementation and the restriction on transferring shared channels, one has to take extra measures when transferring socket channels created by accepting the connection out of the socket commands callback procedures:

    socket -server _Accept 2200
    proc _Accept {s ipaddr port} {
        after idle [list Accept $s $ipaddr $port]
    }
    proc Accept {s ipaddr port} {
        set tid [thread::create]
        thread::transfer $tid $s
    }
thread::detach channel

This detaches the specified channel from the current thread and interpreter. After that, the current interpreter has no access to the channel any more. The channel is in the parked state until some other (or the same) thread attaches the channel again with thread::attach. Restrictions: same as for transferring shared channels with the thread::transfer command.

thread::attach channel

This attaches the previously detached channel in the current thread/interpreter. For already existing channels, the command does nothing, i.e. it is not an error to attach the same channel more than once. The first operation will actually perform the operation, while all subsequent operation will just do nothing. Command throws error if the channel cannot be found in the list of detached channels and/or in the current interpreter.

thread::mutex

Mutexes are most common thread synchronization primitives. They are used to synchronize access from two or more threads to one or more shared resources. This command provides script-level access to exclusive and/or recursive mutexes. Exclusive mutexes can be locked only once by one thread, while recursive mutexes can be locked many times by the same thread. For recursive mutexes, number of lock and unlock operations must match, otherwise, the mutex will never be released, which would lead to various deadlock situations.

Care has to be taken when using mutexes in an multithreading program. Improper use of mutexes may lead to various deadlock situations, especially when using exclusive mutexes.

The thread::mutex command supports following subcommands and options:

thread::mutex create ?-recursive?

Creates the mutex and returns it's opaque handle. This handle should be used for any future reference to the newly created mutex. If no optional ?-recursive? argument was specified, the command creates the exclusive mutex. With the ?-recursive? argument, the command creates a recursive mutex.

thread::mutex destroy mutex

Destroys the mutex. Mutex should be in unlocked state before the destroy attempt. If the mutex is locked, the command will throw Tcl error.

thread::mutex lock mutex

Locks the mutex. Locking the exclusive mutex may throw Tcl error if on attempt to lock the same mutex twice from the same thread. If your program logic forces you to lock the same mutex twice or more from the same thread (this may happen in recursive procedure invocations) you should consider using the recursive mutexes.

thread::mutex unlock mutex

Unlocks the mutex so some other thread may lock it again. Attempt to unlock the already unlocked mutex will throw Tcl error.

thread::rwmutex

This command creates many-readers/single-writer mutexes. Reader/writer mutexes allow you to serialize access to a shared resource more optimally. In situations where a shared resource gets mostly read and seldom modified, you might gain some performance by using reader/writer mutexes instead of exclusive or recursive mutexes.

For reading the resource, thread should obtain a read lock on the resource. Read lock is non-exclusive, meaning that more than one thread can obtain a read lock to the same resource, without waiting on other readers. For changing the resource, however, a thread must obtain a exclusive write lock. This lock effectively blocks all threads from gaining the read-lock while the resource is been modified by the writer thread. Only after the write lock has been released, the resource may be read-locked again.

The thread::rwmutex command supports following subcommands and options:

thread::rwmutex create

Creates the reader/writer mutex and returns it's opaque handle. This handle should be used for any future reference to the newly created mutex.

thread::rwmutex destroy mutex

Destroys the reader/writer mutex. If the mutex is already locked, attempt to destroy it will throw Tcl error.

thread::rwmutex rlock mutex

Locks the mutex for reading. More than one thread may read-lock the same mutex at the same time.

thread::rwmutex wlock mutex

Locks the mutex for writing. Only one thread may write-lock the same mutex at the same time. Attempt to write-lock same mutex twice from the same thread will throw Tcl error.

thread::rwmutex unlock mutex

Unlocks the mutex so some other thread may lock it again. Attempt to unlock already unlocked mutex will throw Tcl error.

thread::cond

This command provides script-level access to condition variables. A condition variable creates a safe environment for the program to test some condition, sleep on it when false and be awakened when it might have become true. A condition variable is always used in the conjunction with an exclusive mutex. If you attempt to use other type of mutex in conjunction with the condition variable, a Tcl error will be thrown.

The command supports following subcommands and options:

thread::cond create

Creates the condition variable and returns it's opaque handle. This handle should be used for any future reference to newly created condition variable.

thread::cond destroy cond

Destroys condition variable cond. Extreme care has to be taken that nobody is using (i.e. waiting on) the condition variable, otherwise unexpected errors may happen.

thread::cond notify cond

Wakes up all threads waiting on the condition variable cond.

thread::cond wait cond mutex ?ms?

This command is used to suspend program execution until the condition variable cond has been signalled or the optional timer has expired. The exclusive mutex must be locked by the calling thread on entrance to this command. If the mutex is not locked, Tcl error is thrown. While waiting on the cond, the command releases mutex. Before returning to the calling thread, the command re-acquires the mutex again. Unlocking the mutex and waiting on the condition variable cond is done atomically.

The ms command option, if given, must be an integer specifying time interval in milliseconds the command waits to be signalled. Otherwise the command waits on condition notify forever.

In multithreading programs, there are many situations where a thread has to wait for some event to happen until it is allowed to proceed. This is usually accomplished by repeatedly testing a condition under the mutex protection and waiting on the condition variable until the condition evaluates to true:

    set mutex [thread::mutex create]
    set cond  [thread::cond  create]
    thread::mutex lock $mutex
    while {<some_condition_is_true>} {
        thread::cond wait $cond $mutex
    }
    # Do some work under mutex protection
    thread::mutex unlock $mutex

Repeated testing of the condition is needed since the condition variable may get signalled without the condition being actually changed (spurious thread wake-ups, for example).

DISCUSSION

The fundamental threading model in Tcl is that there can be one or more Tcl interpreters per thread, but each Tcl interpreter should only be used by a single thread which created it. A "shared memory" abstraction is awkward to provide in Tcl because Tcl makes assumptions about variable and data ownership. Therefore this extension supports a simple form of threading where the main thread can manage several background, or "worker" threads. For example, an event-driven server can pass requests to worker threads, and then await responses from worker threads or new client requests. Everything goes through the common Tcl event loop, so message passing between threads works naturally with event-driven I/O, vwait on variables, and so forth. For the transfer of bulk information it is possible to move channels between the threads.

For advanced multithreading scripts, script-level access to two basic synchronization primitives, mutex and condition variables, is also supported.

Keywords

events, message passing, mutex, synchronization, thread

thread3.0.1/doc/man/0000755003604700454610000000000014731057541012627 5ustar dgp771divthread3.0.1/doc/man/ttrace.n0000644003604700454610000003575614726633451014314 0ustar dgp771div'\" '\" Generated from file '' by tcllib/doctools with format 'nroff' '\" .TH "ttrace" n 3\&.0 "Tcl Threading" .\" The -*- nroff -*- definitions below are for supplemental macros used .\" in Tcl/Tk manual entries. .\" .\" .AP type name in/out ?indent? .\" Start paragraph describing an argument to a library procedure. .\" type is type of argument (int, etc.), in/out is either "in", "out", .\" or "in/out" to describe whether procedure reads or modifies arg, .\" and indent is equivalent to second arg of .IP (shouldn't ever be .\" needed; use .AS below instead) .\" .\" .AS ?type? ?name? .\" Give maximum sizes of arguments for setting tab stops. Type and .\" name are examples of largest possible arguments that will be passed .\" to .AP later. If args are omitted, default tab stops are used. .\" .\" .BS .\" Start box enclosure. From here until next .BE, everything will be .\" enclosed in one large box. .\" .\" .BE .\" End of box enclosure. .\" .\" .CS .\" Begin code excerpt. .\" .\" .CE .\" End code excerpt. .\" .\" .VS ?version? ?br? .\" Begin vertical sidebar, for use in marking newly-changed parts .\" of man pages. The first argument is ignored and used for recording .\" the version when the .VS was added, so that the sidebars can be .\" found and removed when they reach a certain age. If another argument .\" is present, then a line break is forced before starting the sidebar. .\" .\" .VE .\" End of vertical sidebar. .\" .\" .DS .\" Begin an indented unfilled display. .\" .\" .DE .\" End of indented unfilled display. .\" .\" .SO ?manpage? .\" Start of list of standard options for a Tk widget. The manpage .\" argument defines where to look up the standard options; if .\" omitted, defaults to "options". The options follow on successive .\" lines, in three columns separated by tabs. .\" .\" .SE .\" End of list of standard options for a Tk widget. .\" .\" .OP cmdName dbName dbClass .\" Start of description of a specific option. cmdName gives the .\" option's name as specified in the class command, dbName gives .\" the option's name in the option database, and dbClass gives .\" the option's class in the option database. .\" .\" .UL arg1 arg2 .\" Print arg1 underlined, then print arg2 normally. .\" .\" .QW arg1 ?arg2? .\" Print arg1 in quotes, then arg2 normally (for trailing punctuation). .\" .\" .PQ arg1 ?arg2? .\" Print an open parenthesis, arg1 in quotes, then arg2 normally .\" (for trailing punctuation) and then a closing parenthesis. .\" .\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages. .if t .wh -1.3i ^B .nr ^l \n(.l .ad b .\" # Start an argument description .de AP .ie !"\\$4"" .TP \\$4 .el \{\ . ie !"\\$2"" .TP \\n()Cu . el .TP 15 .\} .ta \\n()Au \\n()Bu .ie !"\\$3"" \{\ \&\\$1 \\fI\\$2\\fP (\\$3) .\".b .\} .el \{\ .br .ie !"\\$2"" \{\ \&\\$1 \\fI\\$2\\fP .\} .el \{\ \&\\fI\\$1\\fP .\} .\} .. .\" # define tabbing values for .AP .de AS .nr )A 10n .if !"\\$1"" .nr )A \\w'\\$1'u+3n .nr )B \\n()Au+15n .\" .if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n .nr )C \\n()Bu+\\w'(in/out)'u+2n .. .AS Tcl_Interp Tcl_CreateInterp in/out .\" # BS - start boxed text .\" # ^y = starting y location .\" # ^b = 1 .de BS .br .mk ^y .nr ^b 1u .if n .nf .if n .ti 0 .if n \l'\\n(.lu\(ul' .if n .fi .. .\" # BE - end boxed text (draw box now) .de BE .nf .ti 0 .mk ^t .ie n \l'\\n(^lu\(ul' .el \{\ .\" Draw four-sided box normally, but don't draw top of .\" box if the box started on an earlier page. .ie !\\n(^b-1 \{\ \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .el \}\ \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .\} .fi .br .nr ^b 0 .. .\" # VS - start vertical sidebar .\" # ^Y = starting y location .\" # ^v = 1 (for troff; for nroff this doesn't matter) .de VS .if !"\\$2"" .br .mk ^Y .ie n 'mc \s12\(br\s0 .el .nr ^v 1u .. .\" # VE - end of vertical sidebar .de VE .ie n 'mc .el \{\ .ev 2 .nf .ti 0 .mk ^t \h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n' .sp -1 .fi .ev .\} .nr ^v 0 .. .\" # Special macro to handle page bottom: finish off current .\" # box/sidebar if in box/sidebar mode, then invoked standard .\" # page bottom macro. .de ^B .ev 2 'ti 0 'nf .mk ^t .if \\n(^b \{\ .\" Draw three-sided box if this is the box's first page, .\" draw two sides but no top otherwise. .ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c .el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c .\} .if \\n(^v \{\ .nr ^x \\n(^tu+1v-\\n(^Yu \kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c .\} .bp 'fi .ev .if \\n(^b \{\ .mk ^y .nr ^b 2 .\} .if \\n(^v \{\ .mk ^Y .\} .. .\" # DS - begin display .de DS .RS .nf .sp .. .\" # DE - end display .de DE .fi .RE .sp .. .\" # SO - start of list of standard options .de SO 'ie '\\$1'' .ds So \\fBoptions\\fR 'el .ds So \\fB\\$1\\fR .SH "STANDARD OPTIONS" .LP .nf .ta 5.5c 11c .ft B .. .\" # SE - end of list of standard options .de SE .fi .ft R .LP See the \\*(So manual entry for details on the standard options. .. .\" # OP - start of full description for a single option .de OP .LP .nf .ta 4c Command-Line Name: \\fB\\$1\\fR Database Name: \\fB\\$2\\fR Database Class: \\fB\\$3\\fR .fi .IP .. .\" # CS - begin code excerpt .de CS .RS .nf .ta .25i .5i .75i 1i .. .\" # CE - end code excerpt .de CE .fi .RE .. .\" # UL - underline word .de UL \\$1\l'|0\(ul'\\$2 .. .\" # QW - apply quotation marks to word .de QW .ie '\\*(lq'"' ``\\$1''\\$2 .\"" fix emacs highlighting .el \\*(lq\\$1\\*(rq\\$2 .. .\" # PQ - apply parens and quotation marks to word .de PQ .ie '\\*(lq'"' (``\\$1''\\$2)\\$3 .\"" fix emacs highlighting .el (\\*(lq\\$1\\*(rq\\$2)\\$3 .. .\" # QR - quoted range .de QR .ie '\\*(lq'"' ``\\$1''\\-``\\$2''\\$3 .\"" fix emacs highlighting .el \\*(lq\\$1\\*(rq\\-\\*(lq\\$2\\*(rq\\$3 .. .\" # MT - "empty" string .de MT .QW "" .. .BS .SH NAME ttrace \- Trace-based interpreter initialization .SH SYNOPSIS package require \fBTcl 9\&.0\fR .sp package require \fBthread ?3\&.0?\fR .sp \fBttrace::eval\fR \fIarg\fR ?arg \&.\&.\&.? .sp \fBttrace::enable\fR .sp \fBttrace::disable\fR .sp \fBttrace::cleanup\fR .sp \fBttrace::update\fR ?epoch? .sp \fBttrace::getscript\fR .sp \fBttrace::atenable\fR \fIcmd\fR \fIarglist\fR \fIbody\fR .sp \fBttrace::atdisable\fR \fIcmd\fR \fIarglist\fR \fIbody\fR .sp \fBttrace::addtrace\fR \fIcmd\fR \fIarglist\fR \fIbody\fR .sp \fBttrace::addscript\fR \fIname\fR \fIbody\fR .sp \fBttrace::addresolver\fR \fIcmd\fR \fIarglist\fR \fIbody\fR .sp \fBttrace::addcleanup\fR \fIbody\fR .sp \fBttrace::addentry\fR \fIcmd\fR \fIvar\fR \fIval\fR .sp \fBttrace::getentry\fR \fIcmd\fR \fIvar\fR .sp \fBttrace::getentries\fR \fIcmd\fR ?pattern? .sp \fBttrace::delentry\fR \fIcmd\fR .sp \fBttrace::preload\fR \fIcmd\fR .sp .BE .SH DESCRIPTION This package creates a framework for on-demand replication of the interpreter state across threads in an multithreading application\&. It relies on the mechanics of Tcl command tracing and the Tcl \fBunknown\fR command and mechanism\&. .PP The package requires Tcl threading extension but can be alternatively used stand-alone within the AOLserver, a scalable webserver from America Online\&. .PP In a nutshell, a short sample illustrating the usage of the ttrace with the Tcl threading extension: .CS % package require ttrace 3\&.0\&.1 % set t1 [thread::create {package require ttrace; thread::wait}] tid0x1802800 % ttrace::eval {proc test args {return test-[thread::id]}} % thread::send $t1 test test-tid0x1802800 % set t2 [thread::create {package require ttrace; thread::wait}] tid0x1804000 % thread::send $t2 test test-tid0x1804000 .CE .PP As seen from above, the \fBttrace::eval\fR and \fBttrace::update\fR commands are used to create a thread-wide definition of a simple Tcl procedure and replicate that definition to all, already existing or later created, threads\&. .SH "USER COMMANDS" This section describes user-level commands\&. Those commands can be used by script writers to control the execution of the tracing framework\&. .TP \fBttrace::eval\fR \fIarg\fR ?arg \&.\&.\&.? This command concatenates given arguments and evaluates the resulting Tcl command with trace framework enabled\&. If the command execution was ok, it takes necessary steps to automatically propagate the trace epoch change to all threads in the application\&. For AOLserver, only newly created threads actually receive the epoch change\&. For the Tcl threading extension, all threads created by the extension are automatically updated\&. If the command execution resulted in Tcl error, no state propagation takes place\&. .sp This is the most important user-level command of the package as it wraps most of the commands described below\&. This greatly simplifies things, because user need to learn just this (one) command in order to effectively use the package\&. Other commands, as described below, are included mostly for the sake of completeness\&. .TP \fBttrace::enable\fR Activates all registered callbacks in the framework and starts a new trace epoch\&. The trace epoch encapsulates all changes done to the interpreter during the time traces are activated\&. .TP \fBttrace::disable\fR Deactivates all registered callbacks in the framework and closes the current trace epoch\&. .TP \fBttrace::cleanup\fR Used to clean-up all on-demand loaded resources in the interpreter\&. It effectively brings Tcl interpreter to its pristine state\&. .TP \fBttrace::update\fR ?epoch? Used to refresh the state of the interpreter to match the optional trace ?epoch?\&. If the optional ?epoch? is not given, it takes the most recent trace epoch\&. .TP \fBttrace::getscript\fR Returns a synthesized Tcl script which may be sourced in any interpreter\&. This script sets the stage for the Tcl \fBunknown\fR command so it can load traced resources from the in-memory database\&. Normally, this command is automatically invoked by other higher-level commands like \fBttrace::eval\fR and \fBttrace::update\fR\&. .PP .SH "CALLBACK COMMANDS" A word upfront: the package already includes callbacks for tracing following Tcl commands: \fBproc\fR, \fBnamespace\fR, \fBvariable\fR, \fBload\fR, and \fBrename\fR\&. Additionally, a set of callbacks for tracing resources (object, classes) for the XOTcl v1\&.3\&.8+, an OO-extension to Tcl, is also provided\&. This gives a solid base for solving most of the real-life needs and serves as an example for people wanting to customize the package to cover their specific needs\&. .PP Below, you can find commands for registering callbacks in the framework and for writing callback scripts\&. These callbacks are invoked by the framework in order to gather interpreter state changes, build in-memory database, perform custom-cleanups and various other tasks\&. .TP \fBttrace::atenable\fR \fIcmd\fR \fIarglist\fR \fIbody\fR Registers Tcl callback to be activated at \fBttrace::enable\fR\&. Registered callbacks are activated on FIFO basis\&. The callback definition includes the name of the callback, \fIcmd\fR, a list of callback arguments, \fIarglist\fR and the \fIbody\fR of the callback\&. Effectively, this actually resembles the call interface of the standard Tcl \fBproc\fR command\&. .TP \fBttrace::atdisable\fR \fIcmd\fR \fIarglist\fR \fIbody\fR Registers Tcl callback to be activated at \fBttrace::disable\fR\&. Registered callbacks are activated on FIFO basis\&. The callback definition includes the name of the callback, \fIcmd\fR, a list of callback arguments, \fIarglist\fR and the \fIbody\fR of the callback\&. Effectively, this actually resembles the call interface of the standard Tcl \fBproc\fR command\&. .TP \fBttrace::addtrace\fR \fIcmd\fR \fIarglist\fR \fIbody\fR Registers Tcl callback to be activated for tracing the Tcl \fBcmd\fR command\&. The callback definition includes the name of the Tcl command to trace, \fIcmd\fR, a list of callback arguments, \fIarglist\fR and the \fIbody\fR of the callback\&. Effectively, this actually resembles the call interface of the standard Tcl \fBproc\fR command\&. .TP \fBttrace::addscript\fR \fIname\fR \fIbody\fR Registers Tcl callback to be activated for building a Tcl script to be passed to other interpreters\&. This script is used to set the stage for the Tcl \fBunknown\fR command\&. Registered callbacks are activated on FIFO basis\&. The callback definition includes the name of the callback, \fIname\fR and the \fIbody\fR of the callback\&. .TP \fBttrace::addresolver\fR \fIcmd\fR \fIarglist\fR \fIbody\fR Registers Tcl callback to be activated by the overloaded Tcl \fBunknown\fR command\&. Registered callbacks are activated on FIFO basis\&. This callback is used to resolve the resource and load the resource in the current interpreter\&. .TP \fBttrace::addcleanup\fR \fIbody\fR Registers Tcl callback to be activated by the \fBtrace::cleanup\fR\&. Registered callbacks are activated on FIFO basis\&. .TP \fBttrace::addentry\fR \fIcmd\fR \fIvar\fR \fIval\fR Adds one entry to the named in-memory database\&. .TP \fBttrace::getentry\fR \fIcmd\fR \fIvar\fR Returns the value of the entry from the named in-memory database\&. .TP \fBttrace::getentries\fR \fIcmd\fR ?pattern? Returns names of all entries from the named in-memory database\&. .TP \fBttrace::delentry\fR \fIcmd\fR Deletes an entry from the named in-memory database\&. .TP \fBttrace::preload\fR \fIcmd\fR Registers the Tcl command to be loaded in the interpreter\&. Commands registered this way will always be the part of the interpreter and not be on-demand loaded by the Tcl \fBunknown\fR command\&. .PP .SH DISCUSSION Common introspective state-replication approaches use a custom Tcl script to introspect the running interpreter and synthesize another Tcl script to replicate this state in some other interpreter\&. This package, on the contrary, uses Tcl command traces\&. Command traces are registered on selected Tcl commands, like \fBproc\fR, \fBnamespace\fR, \fBload\fR and other standard (and/or user-defined) Tcl commands\&. When activated, those traces build an in-memory database of created resources\&. This database is used as a resource repository for the (overloaded) Tcl \fBunknown\fR command which creates the requested resource in the interpreter on demand\&. This way, users can update just one interpreter (master) in one thread and replicate that interpreter state (or part of it) to other threads/interpreters in the process\&. .PP Immediate benefit of such approach is the much smaller memory footprint of the application and much faster thread creation\&. By not actually loading all necessary procedures (and other resources) in every thread at the thread initialization time, but by deferring this to the time the resource is actually referenced, significant improvements in both memory consumption and thread initialization time can be achieved\&. Some tests have shown that memory footprint of an multithreading Tcl application went down more than three times and thread startup time was reduced for about 50 times\&. Note that your mileage may vary\&. Other benefits include much finer control about what (and when) gets replicated from the master to other Tcl thread/interpreters\&. .SH "SEE ALSO" thread, tpool, tsv .SH KEYWORDS command tracing, introspection thread3.0.1/doc/man/tsv.n0000644003604700454610000005105414726633451013633 0ustar dgp771div'\" '\" Generated from file '' by tcllib/doctools with format 'nroff' '\" .TH "tsv" n 3\&.0 "Tcl Threading" .\" The -*- nroff -*- definitions below are for supplemental macros used .\" in Tcl/Tk manual entries. .\" .\" .AP type name in/out ?indent? .\" Start paragraph describing an argument to a library procedure. .\" type is type of argument (int, etc.), in/out is either "in", "out", .\" or "in/out" to describe whether procedure reads or modifies arg, .\" and indent is equivalent to second arg of .IP (shouldn't ever be .\" needed; use .AS below instead) .\" .\" .AS ?type? ?name? .\" Give maximum sizes of arguments for setting tab stops. Type and .\" name are examples of largest possible arguments that will be passed .\" to .AP later. If args are omitted, default tab stops are used. .\" .\" .BS .\" Start box enclosure. From here until next .BE, everything will be .\" enclosed in one large box. .\" .\" .BE .\" End of box enclosure. .\" .\" .CS .\" Begin code excerpt. .\" .\" .CE .\" End code excerpt. .\" .\" .VS ?version? ?br? .\" Begin vertical sidebar, for use in marking newly-changed parts .\" of man pages. The first argument is ignored and used for recording .\" the version when the .VS was added, so that the sidebars can be .\" found and removed when they reach a certain age. If another argument .\" is present, then a line break is forced before starting the sidebar. .\" .\" .VE .\" End of vertical sidebar. .\" .\" .DS .\" Begin an indented unfilled display. .\" .\" .DE .\" End of indented unfilled display. .\" .\" .SO ?manpage? .\" Start of list of standard options for a Tk widget. The manpage .\" argument defines where to look up the standard options; if .\" omitted, defaults to "options". The options follow on successive .\" lines, in three columns separated by tabs. .\" .\" .SE .\" End of list of standard options for a Tk widget. .\" .\" .OP cmdName dbName dbClass .\" Start of description of a specific option. cmdName gives the .\" option's name as specified in the class command, dbName gives .\" the option's name in the option database, and dbClass gives .\" the option's class in the option database. .\" .\" .UL arg1 arg2 .\" Print arg1 underlined, then print arg2 normally. .\" .\" .QW arg1 ?arg2? .\" Print arg1 in quotes, then arg2 normally (for trailing punctuation). .\" .\" .PQ arg1 ?arg2? .\" Print an open parenthesis, arg1 in quotes, then arg2 normally .\" (for trailing punctuation) and then a closing parenthesis. .\" .\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages. .if t .wh -1.3i ^B .nr ^l \n(.l .ad b .\" # Start an argument description .de AP .ie !"\\$4"" .TP \\$4 .el \{\ . ie !"\\$2"" .TP \\n()Cu . el .TP 15 .\} .ta \\n()Au \\n()Bu .ie !"\\$3"" \{\ \&\\$1 \\fI\\$2\\fP (\\$3) .\".b .\} .el \{\ .br .ie !"\\$2"" \{\ \&\\$1 \\fI\\$2\\fP .\} .el \{\ \&\\fI\\$1\\fP .\} .\} .. .\" # define tabbing values for .AP .de AS .nr )A 10n .if !"\\$1"" .nr )A \\w'\\$1'u+3n .nr )B \\n()Au+15n .\" .if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n .nr )C \\n()Bu+\\w'(in/out)'u+2n .. .AS Tcl_Interp Tcl_CreateInterp in/out .\" # BS - start boxed text .\" # ^y = starting y location .\" # ^b = 1 .de BS .br .mk ^y .nr ^b 1u .if n .nf .if n .ti 0 .if n \l'\\n(.lu\(ul' .if n .fi .. .\" # BE - end boxed text (draw box now) .de BE .nf .ti 0 .mk ^t .ie n \l'\\n(^lu\(ul' .el \{\ .\" Draw four-sided box normally, but don't draw top of .\" box if the box started on an earlier page. .ie !\\n(^b-1 \{\ \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .el \}\ \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .\} .fi .br .nr ^b 0 .. .\" # VS - start vertical sidebar .\" # ^Y = starting y location .\" # ^v = 1 (for troff; for nroff this doesn't matter) .de VS .if !"\\$2"" .br .mk ^Y .ie n 'mc \s12\(br\s0 .el .nr ^v 1u .. .\" # VE - end of vertical sidebar .de VE .ie n 'mc .el \{\ .ev 2 .nf .ti 0 .mk ^t \h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n' .sp -1 .fi .ev .\} .nr ^v 0 .. .\" # Special macro to handle page bottom: finish off current .\" # box/sidebar if in box/sidebar mode, then invoked standard .\" # page bottom macro. .de ^B .ev 2 'ti 0 'nf .mk ^t .if \\n(^b \{\ .\" Draw three-sided box if this is the box's first page, .\" draw two sides but no top otherwise. .ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c .el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c .\} .if \\n(^v \{\ .nr ^x \\n(^tu+1v-\\n(^Yu \kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c .\} .bp 'fi .ev .if \\n(^b \{\ .mk ^y .nr ^b 2 .\} .if \\n(^v \{\ .mk ^Y .\} .. .\" # DS - begin display .de DS .RS .nf .sp .. .\" # DE - end display .de DE .fi .RE .sp .. .\" # SO - start of list of standard options .de SO 'ie '\\$1'' .ds So \\fBoptions\\fR 'el .ds So \\fB\\$1\\fR .SH "STANDARD OPTIONS" .LP .nf .ta 5.5c 11c .ft B .. .\" # SE - end of list of standard options .de SE .fi .ft R .LP See the \\*(So manual entry for details on the standard options. .. .\" # OP - start of full description for a single option .de OP .LP .nf .ta 4c Command-Line Name: \\fB\\$1\\fR Database Name: \\fB\\$2\\fR Database Class: \\fB\\$3\\fR .fi .IP .. .\" # CS - begin code excerpt .de CS .RS .nf .ta .25i .5i .75i 1i .. .\" # CE - end code excerpt .de CE .fi .RE .. .\" # UL - underline word .de UL \\$1\l'|0\(ul'\\$2 .. .\" # QW - apply quotation marks to word .de QW .ie '\\*(lq'"' ``\\$1''\\$2 .\"" fix emacs highlighting .el \\*(lq\\$1\\*(rq\\$2 .. .\" # PQ - apply parens and quotation marks to word .de PQ .ie '\\*(lq'"' (``\\$1''\\$2)\\$3 .\"" fix emacs highlighting .el (\\*(lq\\$1\\*(rq\\$2)\\$3 .. .\" # QR - quoted range .de QR .ie '\\*(lq'"' ``\\$1''\\-``\\$2''\\$3 .\"" fix emacs highlighting .el \\*(lq\\$1\\*(rq\\-\\*(lq\\$2\\*(rq\\$3 .. .\" # MT - "empty" string .de MT .QW "" .. .BS .SH NAME tsv \- Part of the Tcl threading extension allowing script level manipulation of data shared between threads\&. .SH SYNOPSIS package require \fBTcl 9\&.0\fR .sp package require \fBthread ?3\&.0?\fR .sp \fBtsv::names\fR ?pattern? .sp \fBtsv::object\fR \fIvarname\fR \fIelement\fR .sp \fBtsv::set\fR \fIvarname\fR \fIelement\fR ?value? .sp \fBtsv::get\fR \fIvarname\fR \fIelement\fR ?namedvar? .sp \fBtsv::unset\fR \fIvarname\fR ?element? .sp \fBtsv::exists\fR \fIvarname\fR \fIelement\fR .sp \fBtsv::pop\fR \fIvarname\fR \fIelement\fR .sp \fBtsv::move\fR \fIvarname\fR \fIoldname\fR \fInewname\fR .sp \fBtsv::incr\fR \fIvarname\fR \fIelement\fR ?count? .sp \fBtsv::append\fR \fIvarname\fR \fIelement\fR \fIvalue\fR ?value \&.\&.\&.? .sp \fBtsv::lock\fR \fIvarname\fR \fIarg\fR ?arg \&.\&.\&.? .sp \fBtsv::handlers\fR .sp \fBtsv::lappend\fR \fIvarname\fR \fIelement\fR \fIvalue\fR ?value \&.\&.\&.? .sp \fBtsv::linsert\fR \fIvarname\fR \fIelement\fR \fIindex\fR \fIvalue\fR ?value \&.\&.\&.? .sp \fBtsv::lreplace\fR \fIvarname\fR \fIelement\fR \fIfirst\fR \fIlast\fR ?value \&.\&.\&.? .sp \fBtsv::llength\fR \fIvarname\fR \fIelement\fR .sp \fBtsv::lindex\fR \fIvarname\fR \fIelement\fR ?index? .sp \fBtsv::lrange\fR \fIvarname\fR \fIelement\fR \fIfrom\fR \fIto\fR .sp \fBtsv::lsearch\fR \fIvarname\fR \fIelement\fR ?options? \fIpattern\fR .sp \fBtsv::lset\fR \fIvarname\fR \fIelement\fR \fIindex\fR ?index \&.\&.\&.? \fIvalue\fR .sp \fBtsv::lpop\fR \fIvarname\fR \fIelement\fR ?index? .sp \fBtsv::lpush\fR \fIvarname\fR \fIelement\fR ?index? .sp \fBtsv::array set\fR \fIvarname\fR \fIlist\fR .sp \fBtsv::array get\fR \fIvarname\fR ?pattern? .sp \fBtsv::array names\fR \fIvarname\fR ?pattern? .sp \fBtsv::array size\fR \fIvarname\fR .sp \fBtsv::array reset\fR \fIvarname\fR \fIlist\fR .sp \fBtsv::array bind\fR \fIvarname\fR \fIhandle\fR .sp \fBtsv::array unbind\fR \fIvarname\fR .sp \fBtsv::array isbound\fR \fIvarname\fR .sp \fBtsv::keyldel\fR \fIvarname\fR \fIkeylist\fR \fIkey\fR .sp \fBtsv::keylget\fR \fIvarname\fR \fIkeylist\fR \fIkey\fR ?retvar? .sp \fBtsv::keylkeys\fR \fIvarname\fR \fIkeylist\fR ?key? .sp \fBtsv::keylset\fR \fIvarname\fR \fIkeylist\fR \fIkey\fR \fIvalue\fR ?key value\&.\&.? .sp .BE .SH DESCRIPTION This section describes commands implementing thread shared variables\&. A thread shared variable is very similar to a Tcl array but in contrast to a Tcl array it is created in shared memory and can be accessed from many threads at the same time\&. Important feature of thread shared variable is that each access to the variable is internally protected by a mutex so script programmer does not have to take care about locking the variable himself\&. .PP Thread shared variables are not bound to any thread explicitly\&. That means that when a thread which created any of thread shared variables exits, the variable and associated memory is not unset/reclaimed\&. User has to explicitly unset the variable to reclaim the memory consumed by the variable\&. .SH "ELEMENT COMMANDS" .TP \fBtsv::names\fR ?pattern? Returns names of shared variables matching optional ?pattern? or all known variables if pattern is omitted\&. .TP \fBtsv::object\fR \fIvarname\fR \fIelement\fR Creates object accessor command for the \fIelement\fR in the shared variable \fIvarname\fR\&. Using this command, one can apply most of the other shared variable commands as method functions of the element object command\&. The object command is automatically deleted when the element which this command is pointing to is unset\&. .CS % tsv::set foo bar "A shared string" % set string [tsv::object foo bar] % $string append " appended" => A shared string appended .CE .TP \fBtsv::set\fR \fIvarname\fR \fIelement\fR ?value? Sets the value of the \fIelement\fR in the shared variable \fIvarname\fR to \fIvalue\fR and returns the value to caller\&. The \fIvalue\fR may be omitted, in which case the command will return the current value of the element\&. If the element cannot be found, error is triggered\&. .TP \fBtsv::get\fR \fIvarname\fR \fIelement\fR ?namedvar? Retrieves the value of the \fIelement\fR from the shared variable \fIvarname\fR\&. If the optional argument \fInamedvar\fR is given, the value is stored in the named variable\&. Return value of the command depends of the existence of the optional argument \fInamedvar\fR\&. If the argument is omitted and the requested element cannot be found in the shared array, the command triggers error\&. If, however, the optional argument is given on the command line, the command returns true (1) if the element is found or false (0) if the element is not found\&. .TP \fBtsv::unset\fR \fIvarname\fR ?element? Unsets the \fIelement\fR from the shared variable \fIvarname\fR\&. If the optional element is not given, it deletes the variable\&. .TP \fBtsv::exists\fR \fIvarname\fR \fIelement\fR Checks whether the \fIelement\fR exists in the shared variable \fIvarname\fR and returns true (1) if it does or false (0) if it doesn't\&. .TP \fBtsv::pop\fR \fIvarname\fR \fIelement\fR Returns value of the \fIelement\fR in the shared variable \fIvarname\fR and unsets the element, all in one atomic operation\&. .TP \fBtsv::move\fR \fIvarname\fR \fIoldname\fR \fInewname\fR Renames the element \fIoldname\fR to the \fInewname\fR in the shared variable \fIvarname\fR\&. This effectively performs an get/unset/set sequence of operations but all in one atomic step\&. .TP \fBtsv::incr\fR \fIvarname\fR \fIelement\fR ?count? Similar to standard Tcl \fBincr\fR command but increments the value of the \fIelement\fR in shared variable \fIvarname\fR instead of the Tcl variable\&. .TP \fBtsv::append\fR \fIvarname\fR \fIelement\fR \fIvalue\fR ?value \&.\&.\&.? Similar to standard Tcl \fBappend\fR command but appends one or more values to the \fIelement\fR in shared variable \fIvarname\fR instead of the Tcl variable\&. .TP \fBtsv::lock\fR \fIvarname\fR \fIarg\fR ?arg \&.\&.\&.? This command concatenates passed arguments and evaluates the resulting script under the internal mutex protection\&. During the script evaluation, the entire shared variable is locked\&. For shared variable commands within the script, internal locking is disabled so no deadlock can occur\&. It is also allowed to unset the shared variable from within the script\&. The shared variable is automatically created if it did not exists at the time of the first lock operation\&. .CS % tsv::lock foo { tsv::lappend foo bar 1 tsv::lappend foo bar 2 puts stderr [tsv::set foo bar] tsv::unset foo } .CE .TP \fBtsv::handlers\fR Returns the names of all persistent storage handlers enabled at compile time\&. See \fBARRAY COMMANDS\fR for details\&. .PP .SH "LIST COMMANDS" Those command are similar to the equivalently named Tcl command\&. The difference is that they operate on elements of shared arrays\&. .TP \fBtsv::lappend\fR \fIvarname\fR \fIelement\fR \fIvalue\fR ?value \&.\&.\&.? Similar to standard Tcl \fBlappend\fR command but appends one or more values to the \fIelement\fR in shared variable \fIvarname\fR instead of the Tcl variable\&. .TP \fBtsv::linsert\fR \fIvarname\fR \fIelement\fR \fIindex\fR \fIvalue\fR ?value \&.\&.\&.? Similar to standard Tcl \fBlinsert\fR command but inserts one or more values at the \fIindex\fR list position in the \fIelement\fR in the shared variable \fIvarname\fR instead of the Tcl variable\&. .TP \fBtsv::lreplace\fR \fIvarname\fR \fIelement\fR \fIfirst\fR \fIlast\fR ?value \&.\&.\&.? Similar to standard Tcl \fBlreplace\fR command but replaces one or more values between the \fIfirst\fR and \fIlast\fR position in the \fIelement\fR of the shared variable \fIvarname\fR instead of the Tcl variable\&. .TP \fBtsv::llength\fR \fIvarname\fR \fIelement\fR Similar to standard Tcl \fBllength\fR command but returns length of the \fIelement\fR in the shared variable \fIvarname\fR instead of the Tcl variable\&. .TP \fBtsv::lindex\fR \fIvarname\fR \fIelement\fR ?index? Similar to standard Tcl \fBlindex\fR command but returns the value at the \fIindex\fR list position of the \fIelement\fR from the shared variable \fIvarname\fR instead of the Tcl variable\&. .TP \fBtsv::lrange\fR \fIvarname\fR \fIelement\fR \fIfrom\fR \fIto\fR Similar to standard Tcl \fBlrange\fR command but returns values between \fIfrom\fR and \fIto\fR list positions from the \fIelement\fR in the shared variable \fIvarname\fR instead of the Tcl variable\&. .TP \fBtsv::lsearch\fR \fIvarname\fR \fIelement\fR ?options? \fIpattern\fR Similar to standard Tcl \fBlsearch\fR command but searches the \fIelement\fR in the shared variable \fIvarname\fR instead of the Tcl variable\&. .TP \fBtsv::lset\fR \fIvarname\fR \fIelement\fR \fIindex\fR ?index \&.\&.\&.? \fIvalue\fR Similar to standard Tcl \fBlset\fR command but sets the \fIelement\fR in the shared variable \fIvarname\fR instead of the Tcl variable\&. .TP \fBtsv::lpop\fR \fIvarname\fR \fIelement\fR ?index? Similar to the standard Tcl \fBlindex\fR command but in addition to returning, it also splices the value out of the \fIelement\fR from the shared variable \fIvarname\fR in one atomic operation\&. In contrast to the Tcl \fBlindex\fR command, this command returns no value to the caller\&. .TP \fBtsv::lpush\fR \fIvarname\fR \fIelement\fR ?index? This command performs the opposite of the \fBtsv::lpop\fR command\&. As its counterpart, it returns no value to the caller\&. .PP .SH "ARRAY COMMANDS" This command supports most of the options of the standard Tcl \fBarray\fR command\&. In addition to those, it allows binding a shared variable to some persistent storage databases\&. Currently the persistent options supported are the famous GNU Gdbm and LMDB\&. These options have to be selected during the package compilation time\&. The implementation provides hooks for defining other persistency layers, if needed\&. .TP \fBtsv::array set\fR \fIvarname\fR \fIlist\fR Does the same as standard Tcl \fBarray set\fR\&. .TP \fBtsv::array get\fR \fIvarname\fR ?pattern? Does the same as standard Tcl \fBarray get\fR\&. .TP \fBtsv::array names\fR \fIvarname\fR ?pattern? Does the same as standard Tcl \fBarray names\fR\&. .TP \fBtsv::array size\fR \fIvarname\fR Does the same as standard Tcl \fBarray size\fR\&. .TP \fBtsv::array reset\fR \fIvarname\fR \fIlist\fR Does the same as standard Tcl \fBarray set\fR but it clears the \fIvarname\fR and sets new values from the list atomically\&. .TP \fBtsv::array bind\fR \fIvarname\fR \fIhandle\fR Binds the \fIvarname\fR to the persistent storage \fIhandle\fR\&. The format of the \fIhandle\fR is :
, where is "gdbm" for GNU Gdbm and "lmdb" for LMDB and
is the path to the database file\&. .TP \fBtsv::array unbind\fR \fIvarname\fR Unbinds the shared \fIarray\fR from its bound persistent storage\&. .TP \fBtsv::array isbound\fR \fIvarname\fR Returns true (1) if the shared \fIvarname\fR is bound to some persistent storage or zero (0) if not\&. .PP .SH "KEYED LIST COMMANDS" Keyed list commands are borrowed from the TclX package\&. Keyed lists provide a structured data type built upon standard Tcl lists\&. This is a functionality similar to structs in the C programming language\&. .PP A keyed list is a list in which each element contains a key and value pair\&. These element pairs are stored as lists themselves, where the key is the first element of the list, and the value is the second\&. The key-value pairs are referred to as fields\&. This is an example of a keyed list: .CS {{NAME {Frank Zappa}} {JOB {musician and composer}}} .CE Fields may contain subfields; `\&.' is the separator character\&. Subfields are actually fields where the value is another keyed list\&. Thus the following list has the top level fields ID and NAME, and subfields NAME\&.FIRST and NAME\&.LAST: .CS {ID 106} {NAME {{FIRST Frank} {LAST Zappa}}} .CE There is no limit to the recursive depth of subfields, allowing one to build complex data structures\&. Keyed lists are constructed and accessed via a number of commands\&. All keyed list management commands take the name of the variable containing the keyed list as an argument (i\&.e\&. passed by reference), rather than passing the list directly\&. .TP \fBtsv::keyldel\fR \fIvarname\fR \fIkeylist\fR \fIkey\fR Delete the field specified by \fIkey\fR from the keyed list \fIkeylist\fR in the shared variable \fIvarname\fR\&. This removes both the key and the value from the keyed list\&. .TP \fBtsv::keylget\fR \fIvarname\fR \fIkeylist\fR \fIkey\fR ?retvar? Return the value associated with \fIkey\fR from the keyed list \fIkeylist\fR in the shared variable \fIvarname\fR\&. If the optional \fIretvar\fR is not specified, then the value will be returned as the result of the command\&. In this case, if key is not found in the list, an error will result\&. .sp If \fIretvar\fR is specified and \fIkey\fR is in the list, then the value is returned in the variable \fIretvar\fR and the command returns 1 if the key was present within the list\&. If \fIkey\fR isn't in the list, the command will return 0, and \fIretvar\fR will be left unchanged\&. If {} is specified for \fIretvar\fR, the value is not returned, allowing the Tcl programmer to determine if a \fIkey\fR is present in a keyed list without setting a variable as a side-effect\&. .TP \fBtsv::keylkeys\fR \fIvarname\fR \fIkeylist\fR ?key? Return the a list of the keys in the keyed list \fIkeylist\fR in the shared variable \fIvarname\fR\&. If \fIkey\fR is specified, then it is the name of a key field whose subfield keys are to be retrieved\&. .TP \fBtsv::keylset\fR \fIvarname\fR \fIkeylist\fR \fIkey\fR \fIvalue\fR ?key value\&.\&.? Set the value associated with \fIkey\fR, in the keyed list \fIkeylist\fR to \fIvalue\fR\&. If the \fIkeylist\fR does not exists, it is created\&. If \fIkey\fR is not currently in the list, it will be added\&. If it already exists, \fIvalue\fR replaces the existing value\&. Multiple keywords and values may be specified, if desired\&. .PP .SH DISCUSSION The current implementation of thread shared variables allows for easy and convenient access to data shared between different threads\&. Internally, the data is stored in Tcl objects and all package commands operate on internal data representation, thus minimizing shimmering and improving performance\&. Special care has been taken to assure that all object data is properly locked and deep-copied when moving objects between threads\&. .PP Due to the internal design of the Tcl core, there is no provision of full integration of shared variables within the Tcl syntax, unfortunately\&. All access to shared data must be performed with the supplied package commands\&. Also, variable traces are not supported\&. But even so, benefits of easy, simple and safe shared data manipulation outweighs imposed limitations\&. .SH CREDITS Thread shared variables are inspired by the nsv interface found in AOLserver, a highly scalable Web server from America Online\&. .SH "SEE ALSO" thread, tpool, ttrace .SH KEYWORDS locking, synchronization, thread shared data, threads thread3.0.1/doc/man/tpool.n0000644003604700454610000004153714726633451014161 0ustar dgp771div'\" '\" Generated from file '' by tcllib/doctools with format 'nroff' '\" .TH "tpool" n 3\&.0 "Tcl Threading" .\" The -*- nroff -*- definitions below are for supplemental macros used .\" in Tcl/Tk manual entries. .\" .\" .AP type name in/out ?indent? .\" Start paragraph describing an argument to a library procedure. .\" type is type of argument (int, etc.), in/out is either "in", "out", .\" or "in/out" to describe whether procedure reads or modifies arg, .\" and indent is equivalent to second arg of .IP (shouldn't ever be .\" needed; use .AS below instead) .\" .\" .AS ?type? ?name? .\" Give maximum sizes of arguments for setting tab stops. Type and .\" name are examples of largest possible arguments that will be passed .\" to .AP later. If args are omitted, default tab stops are used. .\" .\" .BS .\" Start box enclosure. From here until next .BE, everything will be .\" enclosed in one large box. .\" .\" .BE .\" End of box enclosure. .\" .\" .CS .\" Begin code excerpt. .\" .\" .CE .\" End code excerpt. .\" .\" .VS ?version? ?br? .\" Begin vertical sidebar, for use in marking newly-changed parts .\" of man pages. The first argument is ignored and used for recording .\" the version when the .VS was added, so that the sidebars can be .\" found and removed when they reach a certain age. If another argument .\" is present, then a line break is forced before starting the sidebar. .\" .\" .VE .\" End of vertical sidebar. .\" .\" .DS .\" Begin an indented unfilled display. .\" .\" .DE .\" End of indented unfilled display. .\" .\" .SO ?manpage? .\" Start of list of standard options for a Tk widget. The manpage .\" argument defines where to look up the standard options; if .\" omitted, defaults to "options". The options follow on successive .\" lines, in three columns separated by tabs. .\" .\" .SE .\" End of list of standard options for a Tk widget. .\" .\" .OP cmdName dbName dbClass .\" Start of description of a specific option. cmdName gives the .\" option's name as specified in the class command, dbName gives .\" the option's name in the option database, and dbClass gives .\" the option's class in the option database. .\" .\" .UL arg1 arg2 .\" Print arg1 underlined, then print arg2 normally. .\" .\" .QW arg1 ?arg2? .\" Print arg1 in quotes, then arg2 normally (for trailing punctuation). .\" .\" .PQ arg1 ?arg2? .\" Print an open parenthesis, arg1 in quotes, then arg2 normally .\" (for trailing punctuation) and then a closing parenthesis. .\" .\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages. .if t .wh -1.3i ^B .nr ^l \n(.l .ad b .\" # Start an argument description .de AP .ie !"\\$4"" .TP \\$4 .el \{\ . ie !"\\$2"" .TP \\n()Cu . el .TP 15 .\} .ta \\n()Au \\n()Bu .ie !"\\$3"" \{\ \&\\$1 \\fI\\$2\\fP (\\$3) .\".b .\} .el \{\ .br .ie !"\\$2"" \{\ \&\\$1 \\fI\\$2\\fP .\} .el \{\ \&\\fI\\$1\\fP .\} .\} .. .\" # define tabbing values for .AP .de AS .nr )A 10n .if !"\\$1"" .nr )A \\w'\\$1'u+3n .nr )B \\n()Au+15n .\" .if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n .nr )C \\n()Bu+\\w'(in/out)'u+2n .. .AS Tcl_Interp Tcl_CreateInterp in/out .\" # BS - start boxed text .\" # ^y = starting y location .\" # ^b = 1 .de BS .br .mk ^y .nr ^b 1u .if n .nf .if n .ti 0 .if n \l'\\n(.lu\(ul' .if n .fi .. .\" # BE - end boxed text (draw box now) .de BE .nf .ti 0 .mk ^t .ie n \l'\\n(^lu\(ul' .el \{\ .\" Draw four-sided box normally, but don't draw top of .\" box if the box started on an earlier page. .ie !\\n(^b-1 \{\ \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .el \}\ \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .\} .fi .br .nr ^b 0 .. .\" # VS - start vertical sidebar .\" # ^Y = starting y location .\" # ^v = 1 (for troff; for nroff this doesn't matter) .de VS .if !"\\$2"" .br .mk ^Y .ie n 'mc \s12\(br\s0 .el .nr ^v 1u .. .\" # VE - end of vertical sidebar .de VE .ie n 'mc .el \{\ .ev 2 .nf .ti 0 .mk ^t \h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n' .sp -1 .fi .ev .\} .nr ^v 0 .. .\" # Special macro to handle page bottom: finish off current .\" # box/sidebar if in box/sidebar mode, then invoked standard .\" # page bottom macro. .de ^B .ev 2 'ti 0 'nf .mk ^t .if \\n(^b \{\ .\" Draw three-sided box if this is the box's first page, .\" draw two sides but no top otherwise. .ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c .el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c .\} .if \\n(^v \{\ .nr ^x \\n(^tu+1v-\\n(^Yu \kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c .\} .bp 'fi .ev .if \\n(^b \{\ .mk ^y .nr ^b 2 .\} .if \\n(^v \{\ .mk ^Y .\} .. .\" # DS - begin display .de DS .RS .nf .sp .. .\" # DE - end display .de DE .fi .RE .sp .. .\" # SO - start of list of standard options .de SO 'ie '\\$1'' .ds So \\fBoptions\\fR 'el .ds So \\fB\\$1\\fR .SH "STANDARD OPTIONS" .LP .nf .ta 5.5c 11c .ft B .. .\" # SE - end of list of standard options .de SE .fi .ft R .LP See the \\*(So manual entry for details on the standard options. .. .\" # OP - start of full description for a single option .de OP .LP .nf .ta 4c Command-Line Name: \\fB\\$1\\fR Database Name: \\fB\\$2\\fR Database Class: \\fB\\$3\\fR .fi .IP .. .\" # CS - begin code excerpt .de CS .RS .nf .ta .25i .5i .75i 1i .. .\" # CE - end code excerpt .de CE .fi .RE .. .\" # UL - underline word .de UL \\$1\l'|0\(ul'\\$2 .. .\" # QW - apply quotation marks to word .de QW .ie '\\*(lq'"' ``\\$1''\\$2 .\"" fix emacs highlighting .el \\*(lq\\$1\\*(rq\\$2 .. .\" # PQ - apply parens and quotation marks to word .de PQ .ie '\\*(lq'"' (``\\$1''\\$2)\\$3 .\"" fix emacs highlighting .el (\\*(lq\\$1\\*(rq\\$2)\\$3 .. .\" # QR - quoted range .de QR .ie '\\*(lq'"' ``\\$1''\\-``\\$2''\\$3 .\"" fix emacs highlighting .el \\*(lq\\$1\\*(rq\\-\\*(lq\\$2\\*(rq\\$3 .. .\" # MT - "empty" string .de MT .QW "" .. .BS .SH NAME tpool \- Part of the Tcl threading extension implementing pools of worker threads\&. .SH SYNOPSIS package require \fBTcl 9\&.0\fR .sp package require \fBthread ?3\&.0?\fR .sp \fBtpool::create\fR ?options? .sp \fBtpool::names\fR .sp \fBtpool::post\fR ?-detached? ?-nowait? \fItpool\fR \fIscript\fR .sp \fBtpool::wait\fR \fItpool\fR \fIjoblist\fR ?varname? .sp \fBtpool::cancel\fR \fItpool\fR \fIjoblist\fR ?varname? .sp \fBtpool::get\fR \fItpool\fR \fIjob\fR .sp \fBtpool::preserve\fR \fItpool\fR .sp \fBtpool::release\fR \fItpool\fR .sp \fBtpool::suspend\fR \fItpool\fR .sp \fBtpool::resume\fR \fItpool\fR .sp .BE .SH DESCRIPTION This package creates and manages pools of worker threads\&. It allows you to post jobs to worker threads and wait for their completion\&. The threadpool implementation is Tcl event-loop aware\&. That means that any time a caller is forced to wait for an event (job being completed or a worker thread becoming idle or initialized), the implementation will enter the event loop and allow for servicing of other pending file or timer (or any other supported) events\&. .SH COMMANDS .TP \fBtpool::create\fR ?options? This command creates new threadpool\&. It accepts several options as key-value pairs\&. Options are used to tune some threadpool parameters\&. The command returns the ID of the newly created threadpool\&. .sp Following options are supported: .RS .TP \fB-minworkers\fR \fInumber\fR Minimum number of worker threads needed for this threadpool instance\&. During threadpool creation, the implementation will create somany worker threads upfront and will keep at least number of them alive during the lifetime of the threadpool instance\&. Default value of this parameter is 0 (zero)\&. which means that a newly threadpool will have no worker threads initially\&. All worker threads will be started on demand by callers running \fBtpool::post\fR command and posting jobs to the job queue\&. .TP \fB-maxworkers\fR \fInumber\fR Maximum number of worker threads allowed for this threadpool instance\&. If a new job is pending and there are no idle worker threads available, the implementation will try to create new worker thread\&. If the number of available worker threads is lower than the given number, new worker thread will start\&. The caller will automatically enter the event loop and wait until the worker thread has initialized\&. If\&. however, the number of available worker threads is equal to the given number, the caller will enter the event loop and wait for the first worker thread to get idle, thus ready to run the job\&. Default value of this parameter is 4 (four), which means that the threadpool instance will allow maximum of 4 worker threads running jobs or being idle waiting for new jobs to get posted to the job queue\&. .TP \fB-idletime\fR \fIseconds\fR Time in seconds an idle worker thread waits for the job to get posted to the job queue\&. If no job arrives during this interval and the time expires, the worker thread will check the number of currently available worker threads and if the number is higher than the number set by the \fBminthreads\fR option, it will exit\&. If an \fBexitscript\fR has been defined, the exiting worker thread will first run the script and then exit\&. Errors from the exit script, if any, are ignored\&. .sp The idle worker thread is not servicing the event loop\&. If you, however, put the worker thread into the event loop, by evaluating the \fBvwait\fR or other related Tcl commands, the worker thread will not be in the idle state, hence the idle timer will not be taken into account\&. Default value for this option is unspecified\&. .TP \fB-initcmd\fR \fIscript\fR Sets a Tcl script used to initialize new worker thread\&. This is usually used to load packages and commands in the worker, set default variables, create namespaces, and such\&. If the passed script runs into a Tcl error, the worker will not be created and the initiating command (either the \fBtpool::create\fR or \fBtpool::post\fR) will throw error\&. Default value for this option is unspecified, hence, the Tcl interpreter of the worker thread will contain just the initial set of Tcl commands\&. .TP \fB-exitcmd\fR \fIscript\fR Sets a Tcl script run when the idle worker thread exits\&. This is normally used to cleanup the state of the worker thread, release reserved resources, cleanup memory and such\&. Default value for this option is unspecified, thus no Tcl script will run on the worker thread exit\&. .RE .sp .TP \fBtpool::names\fR This command returns a list of IDs of threadpools created with the \fBtpool::create\fR command\&. If no threadpools were found, the command will return empty list\&. .TP \fBtpool::post\fR ?-detached? ?-nowait? \fItpool\fR \fIscript\fR This command sends a \fIscript\fR to the target \fItpool\fR threadpool for execution\&. The script will be executed in the first available idle worker thread\&. If there are no idle worker threads available, the command will create new one, enter the event loop and service events until the newly created thread is initialized\&. If the current number of worker threads is equal to the maximum number of worker threads, as defined during the threadpool creation, the command will enter the event loop and service events while waiting for one of the worker threads to become idle\&. If the optional ?-nowait? argument is given, the command just places the job in the pool's job queue without waiting for an idle worker or creating a new one, even if the pool would still have room for additional threads\&. .sp The command returns the ID of the posted job\&. This ID is used for subsequent \fBtpool::wait\fR, \fBtpool::get\fR and \fBtpool::cancel\fR commands to wait for and retrieve result of the posted script, or cancel the posted job respectively\&. If the optional ?-detached? argument is specified, the command will post a detached job\&. A detached job can not be cancelled or waited upon and is not identified by the job ID\&. .sp If the threadpool \fItpool\fR is not found in the list of active thread pools, the command will throw error\&. The error will also be triggered if the newly created worker thread fails to initialize\&. .TP \fBtpool::wait\fR \fItpool\fR \fIjoblist\fR ?varname? This command waits for one or many jobs, whose job IDs are given in the \fIjoblist\fR to get processed by the worker thread(s)\&. If none of the specified jobs are ready, the command will enter the event loop, service events and wait for the first job to get ready\&. .sp The command returns the list of completed job IDs\&. If the optional variable ?varname? is given, it will be set to the list of jobs in the \fIjoblist\fR which are still pending\&. If the threadpool \fItpool\fR is not found in the list of active thread pools, the command will throw error\&. .TP \fBtpool::cancel\fR \fItpool\fR \fIjoblist\fR ?varname? This command cancels the previously posted jobs given by the \fIjoblist\fR to the pool \fItpool\fR\&. Job cancellation succeeds only for job still waiting to be processed\&. If the job is already being executed by one of the worker threads, the job will not be cancelled\&. The command returns the list of cancelled job IDs\&. If the optional variable ?varname? is given, it will be set to the list of jobs in the \fIjoblist\fR which were not cancelled\&. If the threadpool \fItpool\fR is not found in the list of active thread pools, the command will throw error\&. .TP \fBtpool::get\fR \fItpool\fR \fIjob\fR This command retrieves the result of the previously posted \fIjob\fR\&. Only results of jobs waited upon with the \fBtpool::wait\fR command can be retrieved\&. If the execution of the script resulted in error, the command will throw the error and update the \fBerrorInfo\fR and \fBerrorCode\fR variables correspondingly\&. If the pool \fItpool\fR is not found in the list of threadpools, the command will throw error\&. If the job \fIjob\fR is not ready for retrieval, because it is currently being executed by the worker thread, the command will throw error\&. .TP \fBtpool::preserve\fR \fItpool\fR Each call to this command increments the reference counter of the threadpool \fItpool\fR by one (1)\&. Command returns the value of the reference counter after the increment\&. By incrementing the reference counter, the caller signalizes that he/she wishes to use the resource for a longer period of time\&. .TP \fBtpool::release\fR \fItpool\fR Each call to this command decrements the reference counter of the threadpool \fItpool\fR by one (1)\&.Command returns the value of the reference counter after the decrement\&. When the reference counter reaches zero (0), the threadpool \fItpool\fR is marked for termination\&. You should not reference the threadpool after the \fBtpool::release\fR command returns zero\&. The \fItpool\fR handle goes out of scope and should not be used any more\&. Any following reference to the same threadpool handle will result in Tcl error\&. .TP \fBtpool::suspend\fR \fItpool\fR Suspends processing work on this queue\&. All pool workers are paused but additional work can be added to the pool\&. Note that adding the additional work will not increase the number of workers dynamically as the pool processing is suspended\&. Number of workers is maintained to the count that was found prior suspending worker activity\&. If you need to assure certain number of worker threads, use the \fBminworkers\fR option of the \fBtpool::create\fR command\&. .TP \fBtpool::resume\fR \fItpool\fR Resume processing work on this queue\&. All paused (suspended) workers are free to get work from the pool\&. Note that resuming pool operation will just let already created workers to proceed\&. It will not create additional worker threads to handle the work posted to the pool's work queue\&. .PP .SH DISCUSSION Threadpool is one of the most common threading paradigm when it comes to server applications handling a large number of relatively small tasks\&. A very simplistic model for building a server application would be to create a new thread each time a request arrives and service the request in the new thread\&. One of the disadvantages of this approach is that the overhead of creating a new thread for each request is significant; a server that created a new thread for each request would spend more time and consume more system resources in creating and destroying threads than in processing actual user requests\&. In addition to the overhead of creating and destroying threads, active threads consume system resources\&. Creating too many threads can cause the system to run out of memory or trash due to excessive memory consumption\&. .PP A thread pool offers a solution to both the problem of thread life-cycle overhead and the problem of resource trashing\&. By reusing threads for multiple tasks, the thread-creation overhead is spread over many tasks\&. As a bonus, because the thread already exists when a request arrives, the delay introduced by thread creation is eliminated\&. Thus, the request can be serviced immediately\&. Furthermore, by properly tuning the number of threads in the thread pool, resource thrashing may also be eliminated by forcing any request to wait until a thread is available to process it\&. .SH "SEE ALSO" thread, tsv, ttrace .SH KEYWORDS thread, threadpool thread3.0.1/doc/man/thread.n0000644003604700454610000007563514726633451014301 0ustar dgp771div'\" '\" Generated from file '' by tcllib/doctools with format 'nroff' '\" .TH "thread" n 3\&.0 "Tcl Threading" .\" The -*- nroff -*- definitions below are for supplemental macros used .\" in Tcl/Tk manual entries. .\" .\" .AP type name in/out ?indent? .\" Start paragraph describing an argument to a library procedure. .\" type is type of argument (int, etc.), in/out is either "in", "out", .\" or "in/out" to describe whether procedure reads or modifies arg, .\" and indent is equivalent to second arg of .IP (shouldn't ever be .\" needed; use .AS below instead) .\" .\" .AS ?type? ?name? .\" Give maximum sizes of arguments for setting tab stops. Type and .\" name are examples of largest possible arguments that will be passed .\" to .AP later. If args are omitted, default tab stops are used. .\" .\" .BS .\" Start box enclosure. From here until next .BE, everything will be .\" enclosed in one large box. .\" .\" .BE .\" End of box enclosure. .\" .\" .CS .\" Begin code excerpt. .\" .\" .CE .\" End code excerpt. .\" .\" .VS ?version? ?br? .\" Begin vertical sidebar, for use in marking newly-changed parts .\" of man pages. The first argument is ignored and used for recording .\" the version when the .VS was added, so that the sidebars can be .\" found and removed when they reach a certain age. If another argument .\" is present, then a line break is forced before starting the sidebar. .\" .\" .VE .\" End of vertical sidebar. .\" .\" .DS .\" Begin an indented unfilled display. .\" .\" .DE .\" End of indented unfilled display. .\" .\" .SO ?manpage? .\" Start of list of standard options for a Tk widget. The manpage .\" argument defines where to look up the standard options; if .\" omitted, defaults to "options". The options follow on successive .\" lines, in three columns separated by tabs. .\" .\" .SE .\" End of list of standard options for a Tk widget. .\" .\" .OP cmdName dbName dbClass .\" Start of description of a specific option. cmdName gives the .\" option's name as specified in the class command, dbName gives .\" the option's name in the option database, and dbClass gives .\" the option's class in the option database. .\" .\" .UL arg1 arg2 .\" Print arg1 underlined, then print arg2 normally. .\" .\" .QW arg1 ?arg2? .\" Print arg1 in quotes, then arg2 normally (for trailing punctuation). .\" .\" .PQ arg1 ?arg2? .\" Print an open parenthesis, arg1 in quotes, then arg2 normally .\" (for trailing punctuation) and then a closing parenthesis. .\" .\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages. .if t .wh -1.3i ^B .nr ^l \n(.l .ad b .\" # Start an argument description .de AP .ie !"\\$4"" .TP \\$4 .el \{\ . ie !"\\$2"" .TP \\n()Cu . el .TP 15 .\} .ta \\n()Au \\n()Bu .ie !"\\$3"" \{\ \&\\$1 \\fI\\$2\\fP (\\$3) .\".b .\} .el \{\ .br .ie !"\\$2"" \{\ \&\\$1 \\fI\\$2\\fP .\} .el \{\ \&\\fI\\$1\\fP .\} .\} .. .\" # define tabbing values for .AP .de AS .nr )A 10n .if !"\\$1"" .nr )A \\w'\\$1'u+3n .nr )B \\n()Au+15n .\" .if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n .nr )C \\n()Bu+\\w'(in/out)'u+2n .. .AS Tcl_Interp Tcl_CreateInterp in/out .\" # BS - start boxed text .\" # ^y = starting y location .\" # ^b = 1 .de BS .br .mk ^y .nr ^b 1u .if n .nf .if n .ti 0 .if n \l'\\n(.lu\(ul' .if n .fi .. .\" # BE - end boxed text (draw box now) .de BE .nf .ti 0 .mk ^t .ie n \l'\\n(^lu\(ul' .el \{\ .\" Draw four-sided box normally, but don't draw top of .\" box if the box started on an earlier page. .ie !\\n(^b-1 \{\ \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .el \}\ \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .\} .fi .br .nr ^b 0 .. .\" # VS - start vertical sidebar .\" # ^Y = starting y location .\" # ^v = 1 (for troff; for nroff this doesn't matter) .de VS .if !"\\$2"" .br .mk ^Y .ie n 'mc \s12\(br\s0 .el .nr ^v 1u .. .\" # VE - end of vertical sidebar .de VE .ie n 'mc .el \{\ .ev 2 .nf .ti 0 .mk ^t \h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n' .sp -1 .fi .ev .\} .nr ^v 0 .. .\" # Special macro to handle page bottom: finish off current .\" # box/sidebar if in box/sidebar mode, then invoked standard .\" # page bottom macro. .de ^B .ev 2 'ti 0 'nf .mk ^t .if \\n(^b \{\ .\" Draw three-sided box if this is the box's first page, .\" draw two sides but no top otherwise. .ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c .el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c .\} .if \\n(^v \{\ .nr ^x \\n(^tu+1v-\\n(^Yu \kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c .\} .bp 'fi .ev .if \\n(^b \{\ .mk ^y .nr ^b 2 .\} .if \\n(^v \{\ .mk ^Y .\} .. .\" # DS - begin display .de DS .RS .nf .sp .. .\" # DE - end display .de DE .fi .RE .sp .. .\" # SO - start of list of standard options .de SO 'ie '\\$1'' .ds So \\fBoptions\\fR 'el .ds So \\fB\\$1\\fR .SH "STANDARD OPTIONS" .LP .nf .ta 5.5c 11c .ft B .. .\" # SE - end of list of standard options .de SE .fi .ft R .LP See the \\*(So manual entry for details on the standard options. .. .\" # OP - start of full description for a single option .de OP .LP .nf .ta 4c Command-Line Name: \\fB\\$1\\fR Database Name: \\fB\\$2\\fR Database Class: \\fB\\$3\\fR .fi .IP .. .\" # CS - begin code excerpt .de CS .RS .nf .ta .25i .5i .75i 1i .. .\" # CE - end code excerpt .de CE .fi .RE .. .\" # UL - underline word .de UL \\$1\l'|0\(ul'\\$2 .. .\" # QW - apply quotation marks to word .de QW .ie '\\*(lq'"' ``\\$1''\\$2 .\"" fix emacs highlighting .el \\*(lq\\$1\\*(rq\\$2 .. .\" # PQ - apply parens and quotation marks to word .de PQ .ie '\\*(lq'"' (``\\$1''\\$2)\\$3 .\"" fix emacs highlighting .el (\\*(lq\\$1\\*(rq\\$2)\\$3 .. .\" # QR - quoted range .de QR .ie '\\*(lq'"' ``\\$1''\\-``\\$2''\\$3 .\"" fix emacs highlighting .el \\*(lq\\$1\\*(rq\\-\\*(lq\\$2\\*(rq\\$3 .. .\" # MT - "empty" string .de MT .QW "" .. .BS .SH NAME thread \- Extension for script access to Tcl threading .SH SYNOPSIS package require \fBTcl 9\&.0\fR .sp package require \fBthread ?3\&.0?\fR .sp \fBthread::create\fR ?-joinable? ?-preserved? ?script? .sp \fBthread::preserve\fR ?id? .sp \fBthread::release\fR ?-wait? ?id? .sp \fBthread::id\fR .sp \fBthread::errorproc\fR ?procname? .sp \fBthread::cancel\fR ?-unwind? \fIid\fR ?result? .sp \fBthread::unwind\fR .sp \fBthread::exit\fR ?status? .sp \fBthread::names\fR .sp \fBthread::exists\fR \fIid\fR .sp \fBthread::send\fR ?-async? ?-head? \fIid\fR \fIscript\fR ?varname? .sp \fBthread::broadcast\fR \fIscript\fR .sp \fBthread::wait\fR .sp \fBthread::eval\fR ?-lock mutex? \fIarg\fR ?arg \&.\&.\&.? .sp \fBthread::join\fR \fIid\fR .sp \fBthread::configure\fR \fIid\fR ?option? ?value? ?\&.\&.\&.? .sp \fBthread::transfer\fR \fIid\fR \fIchannel\fR .sp \fBthread::detach\fR \fIchannel\fR .sp \fBthread::attach\fR \fIchannel\fR .sp \fBthread::mutex\fR .sp \fBthread::mutex\fR \fBcreate\fR ?-recursive? .sp \fBthread::mutex\fR \fBdestroy\fR \fImutex\fR .sp \fBthread::mutex\fR \fBlock\fR \fImutex\fR .sp \fBthread::mutex\fR \fBunlock\fR \fImutex\fR .sp \fBthread::rwmutex\fR .sp \fBthread::rwmutex\fR \fBcreate\fR .sp \fBthread::rwmutex\fR \fBdestroy\fR \fImutex\fR .sp \fBthread::rwmutex\fR \fBrlock\fR \fImutex\fR .sp \fBthread::rwmutex\fR \fBwlock\fR \fImutex\fR .sp \fBthread::rwmutex\fR \fBunlock\fR \fImutex\fR .sp \fBthread::cond\fR .sp \fBthread::cond\fR \fBcreate\fR .sp \fBthread::cond\fR \fBdestroy\fR \fIcond\fR .sp \fBthread::cond\fR \fBnotify\fR \fIcond\fR .sp \fBthread::cond\fR \fBwait\fR \fIcond\fR \fImutex\fR ?ms? .sp .BE .SH DESCRIPTION The \fBthread\fR extension creates threads that contain Tcl interpreters, and it lets you send scripts to those threads for evaluation\&. Additionally, it provides script-level access to basic thread synchronization primitives, like mutexes and condition variables\&. .SH COMMANDS This section describes commands for creating and destroying threads and sending scripts to threads for evaluation\&. .TP \fBthread::create\fR ?-joinable? ?-preserved? ?script? This command creates a thread that contains a Tcl interpreter\&. The Tcl interpreter either evaluates the optional \fBscript\fR, if specified, or it waits in the event loop for scripts that arrive via the \fBthread::send\fR command\&. The result, if any, of the optional \fBscript\fR is never returned to the caller\&. The result of \fBthread::create\fR is the ID of the thread\&. This is the opaque handle which identifies the newly created thread for all other package commands\&. The handle of the thread goes out of scope automatically when thread is marked for exit (see the \fBthread::release\fR command below)\&. .sp If the optional \fBscript\fR argument contains the \fBthread::wait\fR command the thread will enter into the event loop\&. If such command is not found in the \fBscript\fR the thread will run the \fBscript\fR to the end and exit\&. In that case, the handle may be safely ignored since it refers to a thread which does not exists any more at the time when the command returns\&. .sp Using flag \fB-joinable\fR it is possible to create a joinable thread, i\&.e\&. one upon whose exit can be waited upon by using \fBthread::join\fR command\&. Note that failure to join a thread created with \fB-joinable\fR flag results in resource and memory leaks\&. .sp Threads created by the \fBthread::create\fR cannot be destroyed forcefully\&. Consequently, there is no corresponding thread destroy command\&. A thread may only be released using the \fBthread::release\fR and if its internal reference count drops to zero, the thread is marked for exit\&. This kicks the thread out of the event loop servicing and the thread continues to execute commands passed in the \fBscript\fR argument, following the \fBthread::wait\fR command\&. If this was the last command in the script, as usually the case, the thread will exit\&. .sp It is possible to create a situation in which it may be impossible to terminate the thread, for example by putting some endless loop after the \fBthread::wait\fR or entering the event loop again by doing an vwait-type of command\&. In such cases, the thread may never exit\&. This is considered to be a bad practice and should be avoided if possible\&. This is best illustrated by the example below: .CS # You should never do \&.\&.\&. set tid [thread::create { package require Http thread::wait vwait forever ; # <-- this! }] .CE .IP The thread created in the above example will never be able to exit\&. After it has been released with the last matching \fBthread::release\fR call, the thread will jump out of the \fBthread::wait\fR and continue to execute commands following\&. It will enter \fBvwait\fR command and wait endlessly for events\&. There is no way one can terminate such thread, so you wouldn't want to do this! .sp Each newly created has its internal reference counter set to 0 (zero), i\&.e\&. it is unreserved\&. This counter gets incremented by a call to \fBthread::preserve\fR and decremented by a call to \fBthread::release\fR command\&. These two commands implement simple but effective thread reservation system and offer predictable and controllable thread termination capabilities\&. It is however possible to create initially preserved threads by using flag \fB-preserved\fR of the \fBthread::create\fR command\&. Threads created with this flag have the initial value of the reference counter of 1 (one), and are thus initially marked reserved\&. .TP \fBthread::preserve\fR ?id? This command increments the thread reference counter\&. Each call to this command increments the reference counter by one (1)\&. Command returns the value of the reference counter after the increment\&. If called with the optional thread \fBid\fR, the command preserves the given thread\&. Otherwise the current thread is preserved\&. .sp With reference counting, one can implement controlled access to a shared Tcl thread\&. By incrementing the reference counter, the caller signalizes that he/she wishes to use the thread for a longer period of time\&. By decrementing the counter, caller signalizes that he/she has finished using the thread\&. .TP \fBthread::release\fR ?-wait? ?id? This command decrements the thread reference counter\&. Each call to this command decrements the reference counter by one (1)\&. If called with the optional thread \fBid\fR, the command releases the given thread\&. Otherwise, the current thread is released\&. Command returns the value of the reference counter after the decrement\&. When the reference counter reaches zero (0), the target thread is marked for termination\&. You should not reference the thread after the \fBthread::release\fR command returns zero or negative integer\&. The handle of the thread goes out of scope and should not be used any more\&. Any following reference to the same thread handle will result in Tcl error\&. .sp Optional flag \fB-wait\fR instructs the caller thread to wait for the target thread to exit, if the effect of the command would result in termination of the target thread, i\&.e\&. if the return result would be zero (0)\&. Without the flag, the caller thread does not wait for the target thread to exit\&. Care must be taken when using the \fB-wait\fR, since this may block the caller thread indefinitely\&. This option has been implemented for some special uses of the extension and is deprecated for regular use\&. Regular users should create joinable threads by using the \fB-joinable\fR option of the \fBthread::create\fR command and the \fBthread::join\fR to wait for thread to exit\&. .TP \fBthread::id\fR This command returns the ID of the current thread\&. .TP \fBthread::errorproc\fR ?procname? This command sets a handler for errors that occur in scripts sent asynchronously, using the \fB-async\fR flag of the \fBthread::send\fR command, to other threads\&. If no handler is specified, the current handler is returned\&. The empty string resets the handler to default (unspecified) value\&. An uncaught error in a thread causes an error message to be sent to the standard error channel\&. This default reporting scheme can be changed by registering a procedure which is called to report the error\&. The \fIprocname\fR is called in the interpreter that invoked the \fBthread::errorproc\fR command\&. The \fIprocname\fR is called like this: .CS myerrorproc thread_id errorInfo .CE .TP \fBthread::cancel\fR ?-unwind? \fIid\fR ?result? This command requires Tcl version 8\&.6 or higher\&. .sp Cancels the script being evaluated in the thread given by the \fIid\fR parameter\&. Without the \fB-unwind\fR switch the evaluation stack for the interpreter is unwound until an enclosing catch command is found or there are no further invocations of the interpreter left on the call stack\&. With the \fB-unwind\fR switch the evaluation stack for the interpreter is unwound without regard to any intervening catch command until there are no further invocations of the interpreter left on the call stack\&. If \fIresult\fR is present, it will be used as the error message string; otherwise, a default error message string will be used\&. .TP \fBthread::unwind\fR Use of this command is deprecated in favour of more advanced thread reservation system implemented with \fBthread::preserve\fR and \fBthread::release\fR commands\&. Support for \fBthread::unwind\fR command will disappear in some future major release of the extension\&. .sp This command stops a prior \fBthread::wait\fR command\&. Execution of the script passed to newly created thread will continue from the \fBthread::wait\fR command\&. If \fBthread::wait\fR was the last command in the script, the thread will exit\&. The command returns empty result but may trigger Tcl error with the message "target thread died" in some situations\&. .TP \fBthread::exit\fR ?status? Use of this command is deprecated in favour of more advanced thread reservation system implemented with \fBthread::preserve\fR and \fBthread::release\fR commands\&. Support for \fBthread::exit\fR command will disappear in some future major release of the extension\&. .sp This command forces a thread stuck in the \fBthread::wait\fR command to unconditionally exit\&. The thread's exit status defaults to 666 and can be specified using the optional \fIstatus\fR argument\&. The execution of \fBthread::exit\fR command is guaranteed to leave the program memory in the inconsistent state, produce memory leaks and otherwise affect other subsystem(s) of the Tcl application in an unpredictable manner\&. The command returns empty result but may trigger Tcl error with the message "target thread died" in some situations\&. .TP \fBthread::names\fR This command returns a list of thread IDs\&. These are only for threads that have been created via \fBthread::create\fR command\&. If your application creates other threads at the C level, they are not reported by this command\&. .TP \fBthread::exists\fR \fIid\fR Returns true (1) if thread given by the \fIid\fR parameter exists, false (0) otherwise\&. This applies only for threads that have been created via \fBthread::create\fR command\&. .TP \fBthread::send\fR ?-async? ?-head? \fIid\fR \fIscript\fR ?varname? This command passes a \fIscript\fR to another thread and, optionally, waits for the result\&. If the \fB-async\fR flag is specified, the command does not wait for the result and it returns empty string\&. The target thread must enter it's event loop in order to receive scripts sent via this command\&. This is done by default for threads created without a startup script\&. Threads can enter the event loop explicitly by calling \fBthread::wait\fR or any other relevant Tcl/Tk command, like \fBupdate\fR, \fBvwait\fR, etc\&. .sp Optional \fBvarname\fR specifies name of the variable to store the result of the \fIscript\fR\&. Without the \fB-async\fR flag, the command returns the evaluation code, similarly to the standard Tcl \fBcatch\fR command\&. If, however, the \fB-async\fR flag is specified, the command returns immediately and caller can later \fBvwait\fR on ?varname? to get the result of the passed \fIscript\fR .CS set t1 [thread::create] set t2 [thread::create] thread::send -async $t1 "set a 1" result thread::send -async $t2 "set b 2" result for {set i 0} {$i < 2} {incr i} { vwait result } .CE .IP In the above example, two threads were fed work and both of them were instructed to signalize the same variable "result" in the calling thread\&. The caller entered the event loop twice to get both results\&. Note, however, that the order of the received results may vary, depending on the current system load, type of work done, etc, etc\&. .sp Many threads can simultaneously send scripts to the target thread for execution\&. All of them are entered into the event queue of the target thread and executed on the FIFO basis, intermingled with optional other events pending in the event queue of the target thread\&. Using the optional ?-head? switch, scripts posted to the thread's event queue can be placed on the head, instead on the tail of the queue, thus being executed in the LIFO fashion\&. .TP \fBthread::broadcast\fR \fIscript\fR This command passes a \fIscript\fR to all threads created by the package for execution\&. It does not wait for response from any of the threads\&. .sp The sending thread (the one executing the thread::broadcast command) does not send the script to itself\&. .sp Each receiving thread is directed to place evaluation of the send script at the head of its event queue, stepping in front of any other events awaiting processing\&. .TP \fBthread::wait\fR This enters the event loop so a thread can receive messages from the \fBthread::send\fR command\&. This command should only be used within the script passed to the \fBthread::create\fR\&. It should be the very last command in the script\&. If this is not the case, the exiting thread will continue executing the script lines past the \fBthread::wait\fR which is usually not what you want and/or expect\&. .CS set t1 [thread::create { # # Do some initialization work here # thread::wait ; # Enter the event loop }] .CE .TP \fBthread::eval\fR ?-lock mutex? \fIarg\fR ?arg \&.\&.\&.? This command concatenates passed arguments and evaluates the resulting script under the mutex protection\&. If no mutex is specified by using the ?-lock mutex? optional argument, the internal static mutex is used\&. .TP \fBthread::join\fR \fIid\fR This command waits for the thread with ID \fIid\fR to exit and then returns it's exit code\&. Errors will be returned for threads which are not joinable or already waited upon by another thread\&. Upon the join the handle of the thread has gone out of scope and should not be used any more\&. .TP \fBthread::configure\fR \fIid\fR ?option? ?value? ?\&.\&.\&.? This command configures various low-level aspects of the thread with ID \fIid\fR in the similar way as the standard Tcl command \fBfconfigure\fR configures some Tcl channel options\&. Options currently supported are: \fB-eventmark\fR and \fB-unwindonerror\fR\&. .sp When \fB-eventmark\fR is provided with a value greater than 0 (zero), that value is the maximum number of asynchronously posted scripts that may be pending for the thread\&. \fBthread::send -async\fR blocks until the number of pending scripts in the event loop drops below the \fB-eventmark\fR value\&. .sp When \fB-unwindonerror\fR is provided with a value of true, an error result in a script causes the thread to unwind, making it unavailable to evaluate additional scripts\&. .TP \fBthread::transfer\fR \fIid\fR \fIchannel\fR This moves the specified \fIchannel\fR from the current thread and interpreter to the main interpreter of the thread with the given \fIid\fR\&. After the move the current interpreter has no access to the channel any more, but the main interpreter of the target thread will be able to use it from now on\&. The command waits until the other thread has incorporated the channel\&. Because of this it is possible to deadlock the participating threads by commanding the other through a synchronous \fBthread::send\fR to transfer a channel to us\&. This easily extends into longer loops of threads waiting for each other\&. Other restrictions: the channel in question must not be shared among multiple interpreters running in the sending thread\&. This automatically excludes the special channels for standard input, output and error\&. .sp Due to the internal Tcl core implementation and the restriction on transferring shared channels, one has to take extra measures when transferring socket channels created by accepting the connection out of the \fBsocket\fR commands callback procedures: .CS socket -server _Accept 2200 proc _Accept {s ipaddr port} { after idle [list Accept $s $ipaddr $port] } proc Accept {s ipaddr port} { set tid [thread::create] thread::transfer $tid $s } .CE .TP \fBthread::detach\fR \fIchannel\fR This detaches the specified \fIchannel\fR from the current thread and interpreter\&. After that, the current interpreter has no access to the channel any more\&. The channel is in the parked state until some other (or the same) thread attaches the channel again with \fBthread::attach\fR\&. Restrictions: same as for transferring shared channels with the \fBthread::transfer\fR command\&. .TP \fBthread::attach\fR \fIchannel\fR This attaches the previously detached \fIchannel\fR in the current thread/interpreter\&. For already existing channels, the command does nothing, i\&.e\&. it is not an error to attach the same channel more than once\&. The first operation will actually perform the operation, while all subsequent operation will just do nothing\&. Command throws error if the \fIchannel\fR cannot be found in the list of detached channels and/or in the current interpreter\&. .TP \fBthread::mutex\fR Mutexes are most common thread synchronization primitives\&. They are used to synchronize access from two or more threads to one or more shared resources\&. This command provides script-level access to exclusive and/or recursive mutexes\&. Exclusive mutexes can be locked only once by one thread, while recursive mutexes can be locked many times by the same thread\&. For recursive mutexes, number of lock and unlock operations must match, otherwise, the mutex will never be released, which would lead to various deadlock situations\&. .sp Care has to be taken when using mutexes in an multithreading program\&. Improper use of mutexes may lead to various deadlock situations, especially when using exclusive mutexes\&. .sp The \fBthread::mutex\fR command supports following subcommands and options: .RS .TP \fBthread::mutex\fR \fBcreate\fR ?-recursive? Creates the mutex and returns it's opaque handle\&. This handle should be used for any future reference to the newly created mutex\&. If no optional ?-recursive? argument was specified, the command creates the exclusive mutex\&. With the ?-recursive? argument, the command creates a recursive mutex\&. .TP \fBthread::mutex\fR \fBdestroy\fR \fImutex\fR Destroys the \fImutex\fR\&. Mutex should be in unlocked state before the destroy attempt\&. If the mutex is locked, the command will throw Tcl error\&. .TP \fBthread::mutex\fR \fBlock\fR \fImutex\fR Locks the \fImutex\fR\&. Locking the exclusive mutex may throw Tcl error if on attempt to lock the same mutex twice from the same thread\&. If your program logic forces you to lock the same mutex twice or more from the same thread (this may happen in recursive procedure invocations) you should consider using the recursive mutexes\&. .TP \fBthread::mutex\fR \fBunlock\fR \fImutex\fR Unlocks the \fImutex\fR so some other thread may lock it again\&. Attempt to unlock the already unlocked mutex will throw Tcl error\&. .RE .sp .TP \fBthread::rwmutex\fR This command creates many-readers/single-writer mutexes\&. Reader/writer mutexes allow you to serialize access to a shared resource more optimally\&. In situations where a shared resource gets mostly read and seldom modified, you might gain some performance by using reader/writer mutexes instead of exclusive or recursive mutexes\&. .sp For reading the resource, thread should obtain a read lock on the resource\&. Read lock is non-exclusive, meaning that more than one thread can obtain a read lock to the same resource, without waiting on other readers\&. For changing the resource, however, a thread must obtain a exclusive write lock\&. This lock effectively blocks all threads from gaining the read-lock while the resource is been modified by the writer thread\&. Only after the write lock has been released, the resource may be read-locked again\&. .sp The \fBthread::rwmutex\fR command supports following subcommands and options: .RS .TP \fBthread::rwmutex\fR \fBcreate\fR Creates the reader/writer mutex and returns it's opaque handle\&. This handle should be used for any future reference to the newly created mutex\&. .TP \fBthread::rwmutex\fR \fBdestroy\fR \fImutex\fR Destroys the reader/writer \fImutex\fR\&. If the mutex is already locked, attempt to destroy it will throw Tcl error\&. .TP \fBthread::rwmutex\fR \fBrlock\fR \fImutex\fR Locks the \fImutex\fR for reading\&. More than one thread may read-lock the same \fImutex\fR at the same time\&. .TP \fBthread::rwmutex\fR \fBwlock\fR \fImutex\fR Locks the \fImutex\fR for writing\&. Only one thread may write-lock the same \fImutex\fR at the same time\&. Attempt to write-lock same \fImutex\fR twice from the same thread will throw Tcl error\&. .TP \fBthread::rwmutex\fR \fBunlock\fR \fImutex\fR Unlocks the \fImutex\fR so some other thread may lock it again\&. Attempt to unlock already unlocked \fImutex\fR will throw Tcl error\&. .RE .sp .TP \fBthread::cond\fR This command provides script-level access to condition variables\&. A condition variable creates a safe environment for the program to test some condition, sleep on it when false and be awakened when it might have become true\&. A condition variable is always used in the conjunction with an exclusive mutex\&. If you attempt to use other type of mutex in conjunction with the condition variable, a Tcl error will be thrown\&. .sp The command supports following subcommands and options: .RS .TP \fBthread::cond\fR \fBcreate\fR Creates the condition variable and returns it's opaque handle\&. This handle should be used for any future reference to newly created condition variable\&. .TP \fBthread::cond\fR \fBdestroy\fR \fIcond\fR Destroys condition variable \fIcond\fR\&. Extreme care has to be taken that nobody is using (i\&.e\&. waiting on) the condition variable, otherwise unexpected errors may happen\&. .TP \fBthread::cond\fR \fBnotify\fR \fIcond\fR Wakes up all threads waiting on the condition variable \fIcond\fR\&. .TP \fBthread::cond\fR \fBwait\fR \fIcond\fR \fImutex\fR ?ms? This command is used to suspend program execution until the condition variable \fIcond\fR has been signalled or the optional timer has expired\&. The exclusive \fImutex\fR must be locked by the calling thread on entrance to this command\&. If the mutex is not locked, Tcl error is thrown\&. While waiting on the \fIcond\fR, the command releases \fImutex\fR\&. Before returning to the calling thread, the command re-acquires the \fImutex\fR again\&. Unlocking the \fImutex\fR and waiting on the condition variable \fIcond\fR is done atomically\&. .sp The \fBms\fR command option, if given, must be an integer specifying time interval in milliseconds the command waits to be signalled\&. Otherwise the command waits on condition notify forever\&. .sp In multithreading programs, there are many situations where a thread has to wait for some event to happen until it is allowed to proceed\&. This is usually accomplished by repeatedly testing a condition under the mutex protection and waiting on the condition variable until the condition evaluates to true: .CS set mutex [thread::mutex create] set cond [thread::cond create] thread::mutex lock $mutex while {} { thread::cond wait $cond $mutex } # Do some work under mutex protection thread::mutex unlock $mutex .CE .IP Repeated testing of the condition is needed since the condition variable may get signalled without the condition being actually changed (spurious thread wake-ups, for example)\&. .RE .PP .SH DISCUSSION The fundamental threading model in Tcl is that there can be one or more Tcl interpreters per thread, but each Tcl interpreter should only be used by a single thread which created it\&. A "shared memory" abstraction is awkward to provide in Tcl because Tcl makes assumptions about variable and data ownership\&. Therefore this extension supports a simple form of threading where the main thread can manage several background, or "worker" threads\&. For example, an event-driven server can pass requests to worker threads, and then await responses from worker threads or new client requests\&. Everything goes through the common Tcl event loop, so message passing between threads works naturally with event-driven I/O, \fBvwait\fR on variables, and so forth\&. For the transfer of bulk information it is possible to move channels between the threads\&. .PP For advanced multithreading scripts, script-level access to two basic synchronization primitives, mutex and condition variables, is also supported\&. .SH "SEE ALSO" \fIhttp://www\&.tcl\&.tk/doc/howto/thread_model\&.html\fR, tpool, tsv, ttrace .SH KEYWORDS events, message passing, mutex, synchronization, thread thread3.0.1/doc/ttrace.man0000644003604700454610000002112414726633451014037 0ustar dgp771div[comment {-*- tcl -*- doctools manpage}] [manpage_begin ttrace n 3.0] [moddesc {Tcl Threading}] [titledesc {Trace-based interpreter initialization}] [require Tcl 9.0] [require thread [opt 3.0]] [description] This package creates a framework for on-demand replication of the interpreter state across threads in an multithreading application. It relies on the mechanics of Tcl command tracing and the Tcl [cmd unknown] command and mechanism. [para] The package requires Tcl threading extension but can be alternatively used stand-alone within the AOLserver, a scalable webserver from America Online. [para] In a nutshell, a short sample illustrating the usage of the ttrace with the Tcl threading extension: [example { % package require ttrace 3.0.1 % set t1 [thread::create {package require ttrace; thread::wait}] tid0x1802800 % ttrace::eval {proc test args {return test-[thread::id]}} % thread::send $t1 test test-tid0x1802800 % set t2 [thread::create {package require ttrace; thread::wait}] tid0x1804000 % thread::send $t2 test test-tid0x1804000 }] [para] As seen from above, the [cmd ttrace::eval] and [cmd ttrace::update] commands are used to create a thread-wide definition of a simple Tcl procedure and replicate that definition to all, already existing or later created, threads. [section {USER COMMANDS}] This section describes user-level commands. Those commands can be used by script writers to control the execution of the tracing framework. [list_begin definitions] [call [cmd ttrace::eval] [arg arg] [opt {arg ...}]] This command concatenates given arguments and evaluates the resulting Tcl command with trace framework enabled. If the command execution was ok, it takes necessary steps to automatically propagate the trace epoch change to all threads in the application. For AOLserver, only newly created threads actually receive the epoch change. For the Tcl threading extension, all threads created by the extension are automatically updated. If the command execution resulted in Tcl error, no state propagation takes place. [para] This is the most important user-level command of the package as it wraps most of the commands described below. This greatly simplifies things, because user need to learn just this (one) command in order to effectively use the package. Other commands, as described below, are included mostly for the sake of completeness. [call [cmd ttrace::enable]] Activates all registered callbacks in the framework and starts a new trace epoch. The trace epoch encapsulates all changes done to the interpreter during the time traces are activated. [call [cmd ttrace::disable]] Deactivates all registered callbacks in the framework and closes the current trace epoch. [call [cmd ttrace::cleanup]] Used to clean-up all on-demand loaded resources in the interpreter. It effectively brings Tcl interpreter to its pristine state. [call [cmd ttrace::update] [opt epoch]] Used to refresh the state of the interpreter to match the optional trace [opt epoch]. If the optional [opt epoch] is not given, it takes the most recent trace epoch. [call [cmd ttrace::getscript]] Returns a synthesized Tcl script which may be sourced in any interpreter. This script sets the stage for the Tcl [cmd unknown] command so it can load traced resources from the in-memory database. Normally, this command is automatically invoked by other higher-level commands like [cmd ttrace::eval] and [cmd ttrace::update]. [list_end] [section {CALLBACK COMMANDS}] A word upfront: the package already includes callbacks for tracing following Tcl commands: [cmd proc], [cmd namespace], [cmd variable], [cmd load], and [cmd rename]. Additionally, a set of callbacks for tracing resources (object, classes) for the XOTcl v1.3.8+, an OO-extension to Tcl, is also provided. This gives a solid base for solving most of the real-life needs and serves as an example for people wanting to customize the package to cover their specific needs. [para] Below, you can find commands for registering callbacks in the framework and for writing callback scripts. These callbacks are invoked by the framework in order to gather interpreter state changes, build in-memory database, perform custom-cleanups and various other tasks. [list_begin definitions] [call [cmd ttrace::atenable] [arg cmd] [arg arglist] [arg body]] Registers Tcl callback to be activated at [cmd ttrace::enable]. Registered callbacks are activated on FIFO basis. The callback definition includes the name of the callback, [arg cmd], a list of callback arguments, [arg arglist] and the [arg body] of the callback. Effectively, this actually resembles the call interface of the standard Tcl [cmd proc] command. [call [cmd ttrace::atdisable] [arg cmd] [arg arglist] [arg body]] Registers Tcl callback to be activated at [cmd ttrace::disable]. Registered callbacks are activated on FIFO basis. The callback definition includes the name of the callback, [arg cmd], a list of callback arguments, [arg arglist] and the [arg body] of the callback. Effectively, this actually resembles the call interface of the standard Tcl [cmd proc] command. [call [cmd ttrace::addtrace] [arg cmd] [arg arglist] [arg body]] Registers Tcl callback to be activated for tracing the Tcl [cmd cmd] command. The callback definition includes the name of the Tcl command to trace, [arg cmd], a list of callback arguments, [arg arglist] and the [arg body] of the callback. Effectively, this actually resembles the call interface of the standard Tcl [cmd proc] command. [call [cmd ttrace::addscript] [arg name] [arg body]] Registers Tcl callback to be activated for building a Tcl script to be passed to other interpreters. This script is used to set the stage for the Tcl [cmd unknown] command. Registered callbacks are activated on FIFO basis. The callback definition includes the name of the callback, [arg name] and the [arg body] of the callback. [call [cmd ttrace::addresolver] [arg cmd] [arg arglist] [arg body]] Registers Tcl callback to be activated by the overloaded Tcl [cmd unknown] command. Registered callbacks are activated on FIFO basis. This callback is used to resolve the resource and load the resource in the current interpreter. [call [cmd ttrace::addcleanup] [arg body]] Registers Tcl callback to be activated by the [cmd trace::cleanup]. Registered callbacks are activated on FIFO basis. [call [cmd ttrace::addentry] [arg cmd] [arg var] [arg val]] Adds one entry to the named in-memory database. [call [cmd ttrace::getentry] [arg cmd] [arg var]] Returns the value of the entry from the named in-memory database. [call [cmd ttrace::getentries] [arg cmd] [opt pattern]] Returns names of all entries from the named in-memory database. [call [cmd ttrace::delentry] [arg cmd]] Deletes an entry from the named in-memory database. [call [cmd ttrace::preload] [arg cmd]] Registers the Tcl command to be loaded in the interpreter. Commands registered this way will always be the part of the interpreter and not be on-demand loaded by the Tcl [cmd unknown] command. [list_end] [section DISCUSSION] Common introspective state-replication approaches use a custom Tcl script to introspect the running interpreter and synthesize another Tcl script to replicate this state in some other interpreter. This package, on the contrary, uses Tcl command traces. Command traces are registered on selected Tcl commands, like [cmd proc], [cmd namespace], [cmd load] and other standard (and/or user-defined) Tcl commands. When activated, those traces build an in-memory database of created resources. This database is used as a resource repository for the (overloaded) Tcl [cmd unknown] command which creates the requested resource in the interpreter on demand. This way, users can update just one interpreter (master) in one thread and replicate that interpreter state (or part of it) to other threads/interpreters in the process. [para] Immediate benefit of such approach is the much smaller memory footprint of the application and much faster thread creation. By not actually loading all necessary procedures (and other resources) in every thread at the thread initialization time, but by deferring this to the time the resource is actually referenced, significant improvements in both memory consumption and thread initialization time can be achieved. Some tests have shown that memory footprint of an multithreading Tcl application went down more than three times and thread startup time was reduced for about 50 times. Note that your mileage may vary. Other benefits include much finer control about what (and when) gets replicated from the master to other Tcl thread/interpreters. [see_also tsv tpool thread] [keywords {command tracing} introspection] [manpage_end] thread3.0.1/doc/tsv.man0000644003604700454610000003216214726633451013375 0ustar dgp771div[comment {-*- tcl -*- doctools manpage}] [manpage_begin tsv n 3.0] [moddesc {Tcl Threading}] [titledesc {Part of the Tcl threading extension allowing script level manipulation of data shared between threads.}] [require Tcl 9.0] [require thread [opt 3.0]] [description] This section describes commands implementing thread shared variables. A thread shared variable is very similar to a Tcl array but in contrast to a Tcl array it is created in shared memory and can be accessed from many threads at the same time. Important feature of thread shared variable is that each access to the variable is internally protected by a mutex so script programmer does not have to take care about locking the variable himself. [para] Thread shared variables are not bound to any thread explicitly. That means that when a thread which created any of thread shared variables exits, the variable and associated memory is not unset/reclaimed. User has to explicitly unset the variable to reclaim the memory consumed by the variable. [section {ELEMENT COMMANDS}] [list_begin definitions] [call [cmd tsv::names] [opt pattern]] Returns names of shared variables matching optional [opt pattern] or all known variables if pattern is omitted. [call [cmd tsv::object] [arg varname] [arg element]] Creates object accessor command for the [arg element] in the shared variable [arg varname]. Using this command, one can apply most of the other shared variable commands as method functions of the element object command. The object command is automatically deleted when the element which this command is pointing to is unset. [example { % tsv::set foo bar "A shared string" % set string [tsv::object foo bar] % $string append " appended" => A shared string appended }] [call [cmd tsv::set] [arg varname] [arg element] [opt value]] Sets the value of the [arg element] in the shared variable [arg varname] to [arg value] and returns the value to caller. The [arg value] may be omitted, in which case the command will return the current value of the element. If the element cannot be found, error is triggered. [call [cmd tsv::get] [arg varname] [arg element] [opt namedvar]] Retrieves the value of the [arg element] from the shared variable [arg varname]. If the optional argument [arg namedvar] is given, the value is stored in the named variable. Return value of the command depends of the existence of the optional argument [arg namedvar]. If the argument is omitted and the requested element cannot be found in the shared array, the command triggers error. If, however, the optional argument is given on the command line, the command returns true (1) if the element is found or false (0) if the element is not found. [call [cmd tsv::unset] [arg varname] [opt element]] Unsets the [arg element] from the shared variable [arg varname]. If the optional element is not given, it deletes the variable. [call [cmd tsv::exists] [arg varname] [arg element]] Checks whether the [arg element] exists in the shared variable [arg varname] and returns true (1) if it does or false (0) if it doesn't. [call [cmd tsv::pop] [arg varname] [arg element]] Returns value of the [arg element] in the shared variable [arg varname] and unsets the element, all in one atomic operation. [call [cmd tsv::move] [arg varname] [arg oldname] [arg newname]] Renames the element [arg oldname] to the [arg newname] in the shared variable [arg varname]. This effectively performs an get/unset/set sequence of operations but all in one atomic step. [call [cmd tsv::incr] [arg varname] [arg element] [opt count]] Similar to standard Tcl [cmd incr] command but increments the value of the [arg element] in shared variable [arg varname] instead of the Tcl variable. [call [cmd tsv::append] [arg varname] [arg element] [arg value] [opt {value ...}]] Similar to standard Tcl [cmd append] command but appends one or more values to the [arg element] in shared variable [arg varname] instead of the Tcl variable. [call [cmd tsv::lock] [arg varname] [arg arg] [opt {arg ...}]] This command concatenates passed arguments and evaluates the resulting script under the internal mutex protection. During the script evaluation, the entire shared variable is locked. For shared variable commands within the script, internal locking is disabled so no deadlock can occur. It is also allowed to unset the shared variable from within the script. The shared variable is automatically created if it did not exists at the time of the first lock operation. [example { % tsv::lock foo { tsv::lappend foo bar 1 tsv::lappend foo bar 2 puts stderr [tsv::set foo bar] tsv::unset foo } }] [call [cmd tsv::handlers]] Returns the names of all persistent storage handlers enabled at compile time. See [sectref {ARRAY COMMANDS}] for details. [list_end] [section {LIST COMMANDS}] Those command are similar to the equivalently named Tcl command. The difference is that they operate on elements of shared arrays. [list_begin definitions] [call [cmd tsv::lappend] [arg varname] [arg element] [arg value] [opt {value ...}]] Similar to standard Tcl [cmd lappend] command but appends one or more values to the [arg element] in shared variable [arg varname] instead of the Tcl variable. [call [cmd tsv::linsert] [arg varname] [arg element] [arg index] [arg value] [opt {value ...}]] Similar to standard Tcl [cmd linsert] command but inserts one or more values at the [arg index] list position in the [arg element] in the shared variable [arg varname] instead of the Tcl variable. [call [cmd tsv::lreplace] [arg varname] [arg element] [arg first] [arg last] [opt {value ...}]] Similar to standard Tcl [cmd lreplace] command but replaces one or more values between the [arg first] and [arg last] position in the [arg element] of the shared variable [arg varname] instead of the Tcl variable. [call [cmd tsv::llength] [arg varname] [arg element]] Similar to standard Tcl [cmd llength] command but returns length of the [arg element] in the shared variable [arg varname] instead of the Tcl variable. [call [cmd tsv::lindex] [arg varname] [arg element] [opt index]] Similar to standard Tcl [cmd lindex] command but returns the value at the [arg index] list position of the [arg element] from the shared variable [arg varname] instead of the Tcl variable. [call [cmd tsv::lrange] [arg varname] [arg element] [arg from] [arg to]] Similar to standard Tcl [cmd lrange] command but returns values between [arg from] and [arg to] list positions from the [arg element] in the shared variable [arg varname] instead of the Tcl variable. [call [cmd tsv::lsearch] [arg varname] [arg element] [opt options] [arg pattern]] Similar to standard Tcl [cmd lsearch] command but searches the [arg element] in the shared variable [arg varname] instead of the Tcl variable. [call [cmd tsv::lset] [arg varname] [arg element] [arg index] [opt {index ...}] [arg value]] Similar to standard Tcl [cmd lset] command but sets the [arg element] in the shared variable [arg varname] instead of the Tcl variable. [call [cmd tsv::lpop] [arg varname] [arg element] [opt index]] Similar to the standard Tcl [cmd lindex] command but in addition to returning, it also splices the value out of the [arg element] from the shared variable [arg varname] in one atomic operation. In contrast to the Tcl [cmd lindex] command, this command returns no value to the caller. [call [cmd tsv::lpush] [arg varname] [arg element] [opt index]] This command performs the opposite of the [cmd tsv::lpop] command. As its counterpart, it returns no value to the caller. [list_end] [section {ARRAY COMMANDS}] This command supports most of the options of the standard Tcl [cmd array] command. In addition to those, it allows binding a shared variable to some persistent storage databases. Currently the persistent options supported are the famous GNU Gdbm and LMDB. These options have to be selected during the package compilation time. The implementation provides hooks for defining other persistency layers, if needed. [list_begin definitions] [call [cmd {tsv::array set}] [arg varname] [arg list]] Does the same as standard Tcl [cmd {array set}]. [call [cmd {tsv::array get}] [arg varname] [opt pattern]] Does the same as standard Tcl [cmd {array get}]. [call [cmd {tsv::array names}] [arg varname] [opt pattern]] Does the same as standard Tcl [cmd {array names}]. [call [cmd {tsv::array size}] [arg varname]] Does the same as standard Tcl [cmd {array size}]. [call [cmd {tsv::array reset}] [arg varname] [arg list]] Does the same as standard Tcl [cmd {array set}] but it clears the [arg varname] and sets new values from the list atomically. [call [cmd {tsv::array bind}] [arg varname] [arg handle]] Binds the [arg varname] to the persistent storage [arg handle]. The format of the [arg handle] is :
, where is "gdbm" for GNU Gdbm and "lmdb" for LMDB and
is the path to the database file. [call [cmd {tsv::array unbind}] [arg varname]] Unbinds the shared [arg array] from its bound persistent storage. [call [cmd {tsv::array isbound}] [arg varname]] Returns true (1) if the shared [arg varname] is bound to some persistent storage or zero (0) if not. [list_end] [section {KEYED LIST COMMANDS}] Keyed list commands are borrowed from the TclX package. Keyed lists provide a structured data type built upon standard Tcl lists. This is a functionality similar to structs in the C programming language. [para] A keyed list is a list in which each element contains a key and value pair. These element pairs are stored as lists themselves, where the key is the first element of the list, and the value is the second. The key-value pairs are referred to as fields. This is an example of a keyed list: [example { {{NAME {Frank Zappa}} {JOB {musician and composer}}} }] Fields may contain subfields; `.' is the separator character. Subfields are actually fields where the value is another keyed list. Thus the following list has the top level fields ID and NAME, and subfields NAME.FIRST and NAME.LAST: [example { {ID 106} {NAME {{FIRST Frank} {LAST Zappa}}} }] There is no limit to the recursive depth of subfields, allowing one to build complex data structures. Keyed lists are constructed and accessed via a number of commands. All keyed list management commands take the name of the variable containing the keyed list as an argument (i.e. passed by reference), rather than passing the list directly. [list_begin definitions] [call [cmd tsv::keyldel] [arg varname] [arg keylist] [arg key]] Delete the field specified by [arg key] from the keyed list [arg keylist] in the shared variable [arg varname]. This removes both the key and the value from the keyed list. [call [cmd tsv::keylget] [arg varname] [arg keylist] [arg key] [opt retvar]] Return the value associated with [arg key] from the keyed list [arg keylist] in the shared variable [arg varname]. If the optional [arg retvar] is not specified, then the value will be returned as the result of the command. In this case, if key is not found in the list, an error will result. [para] If [arg retvar] is specified and [arg key] is in the list, then the value is returned in the variable [arg retvar] and the command returns 1 if the key was present within the list. If [arg key] isn't in the list, the command will return 0, and [arg retvar] will be left unchanged. If {} is specified for [arg retvar], the value is not returned, allowing the Tcl programmer to determine if a [arg key] is present in a keyed list without setting a variable as a side-effect. [call [cmd tsv::keylkeys] [arg varname] [arg keylist] [opt key]] Return the a list of the keys in the keyed list [arg keylist] in the shared variable [arg varname]. If [arg key] is specified, then it is the name of a key field whose subfield keys are to be retrieved. [call [cmd tsv::keylset] [arg varname] [arg keylist] [arg key] [arg value] [opt {key value..}]] Set the value associated with [arg key], in the keyed list [arg keylist] to [arg value]. If the [arg keylist] does not exists, it is created. If [arg key] is not currently in the list, it will be added. If it already exists, [arg value] replaces the existing value. Multiple keywords and values may be specified, if desired. [list_end] [section DISCUSSION] The current implementation of thread shared variables allows for easy and convenient access to data shared between different threads. Internally, the data is stored in Tcl objects and all package commands operate on internal data representation, thus minimizing shimmering and improving performance. Special care has been taken to assure that all object data is properly locked and deep-copied when moving objects between threads. [para] Due to the internal design of the Tcl core, there is no provision of full integration of shared variables within the Tcl syntax, unfortunately. All access to shared data must be performed with the supplied package commands. Also, variable traces are not supported. But even so, benefits of easy, simple and safe shared data manipulation outweighs imposed limitations. [section CREDITS] Thread shared variables are inspired by the nsv interface found in AOLserver, a highly scalable Web server from America Online. [see_also tpool ttrace thread] [keywords threads synchronization locking {thread shared data}] [manpage_end] thread3.0.1/doc/tpool.man0000644003604700454610000002530514726633451013717 0ustar dgp771div[comment {-*- tcl -*- doctools manpage}] [manpage_begin tpool n 3.0] [moddesc {Tcl Threading}] [titledesc {Part of the Tcl threading extension implementing pools of worker threads.}] [require Tcl 9.0] [require thread [opt 3.0]] [description] This package creates and manages pools of worker threads. It allows you to post jobs to worker threads and wait for their completion. The threadpool implementation is Tcl event-loop aware. That means that any time a caller is forced to wait for an event (job being completed or a worker thread becoming idle or initialized), the implementation will enter the event loop and allow for servicing of other pending file or timer (or any other supported) events. [section COMMANDS] [list_begin definitions] [call [cmd tpool::create] [opt options]] This command creates new threadpool. It accepts several options as key-value pairs. Options are used to tune some threadpool parameters. The command returns the ID of the newly created threadpool. [para] Following options are supported: [list_begin options] [opt_def -minworkers [arg number]] Minimum number of worker threads needed for this threadpool instance. During threadpool creation, the implementation will create somany worker threads upfront and will keep at least number of them alive during the lifetime of the threadpool instance. Default value of this parameter is 0 (zero). which means that a newly threadpool will have no worker threads initially. All worker threads will be started on demand by callers running [cmd tpool::post] command and posting jobs to the job queue. [opt_def -maxworkers [arg number]] Maximum number of worker threads allowed for this threadpool instance. If a new job is pending and there are no idle worker threads available, the implementation will try to create new worker thread. If the number of available worker threads is lower than the given number, new worker thread will start. The caller will automatically enter the event loop and wait until the worker thread has initialized. If. however, the number of available worker threads is equal to the given number, the caller will enter the event loop and wait for the first worker thread to get idle, thus ready to run the job. Default value of this parameter is 4 (four), which means that the threadpool instance will allow maximum of 4 worker threads running jobs or being idle waiting for new jobs to get posted to the job queue. [opt_def -idletime [arg seconds]] Time in seconds an idle worker thread waits for the job to get posted to the job queue. If no job arrives during this interval and the time expires, the worker thread will check the number of currently available worker threads and if the number is higher than the number set by the [option minthreads] option, it will exit. If an [option exitscript] has been defined, the exiting worker thread will first run the script and then exit. Errors from the exit script, if any, are ignored. [para] The idle worker thread is not servicing the event loop. If you, however, put the worker thread into the event loop, by evaluating the [cmd vwait] or other related Tcl commands, the worker thread will not be in the idle state, hence the idle timer will not be taken into account. Default value for this option is unspecified. [opt_def -initcmd [arg script]] Sets a Tcl script used to initialize new worker thread. This is usually used to load packages and commands in the worker, set default variables, create namespaces, and such. If the passed script runs into a Tcl error, the worker will not be created and the initiating command (either the [cmd tpool::create] or [cmd tpool::post]) will throw error. Default value for this option is unspecified, hence, the Tcl interpreter of the worker thread will contain just the initial set of Tcl commands. [opt_def -exitcmd [arg script]] Sets a Tcl script run when the idle worker thread exits. This is normally used to cleanup the state of the worker thread, release reserved resources, cleanup memory and such. Default value for this option is unspecified, thus no Tcl script will run on the worker thread exit. [list_end] [para] [call [cmd tpool::names]] This command returns a list of IDs of threadpools created with the [cmd tpool::create] command. If no threadpools were found, the command will return empty list. [call [cmd tpool::post] [opt -detached] [opt -nowait] [arg tpool] [arg script]] This command sends a [arg script] to the target [arg tpool] threadpool for execution. The script will be executed in the first available idle worker thread. If there are no idle worker threads available, the command will create new one, enter the event loop and service events until the newly created thread is initialized. If the current number of worker threads is equal to the maximum number of worker threads, as defined during the threadpool creation, the command will enter the event loop and service events while waiting for one of the worker threads to become idle. If the optional [opt -nowait] argument is given, the command just places the job in the pool's job queue without waiting for an idle worker or creating a new one, even if the pool would still have room for additional threads. [para] The command returns the ID of the posted job. This ID is used for subsequent [cmd tpool::wait], [cmd tpool::get] and [cmd tpool::cancel] commands to wait for and retrieve result of the posted script, or cancel the posted job respectively. If the optional [opt -detached] argument is specified, the command will post a detached job. A detached job can not be cancelled or waited upon and is not identified by the job ID. [para] If the threadpool [arg tpool] is not found in the list of active thread pools, the command will throw error. The error will also be triggered if the newly created worker thread fails to initialize. [call [cmd tpool::wait] [arg tpool] [arg joblist] [opt varname]] This command waits for one or many jobs, whose job IDs are given in the [arg joblist] to get processed by the worker thread(s). If none of the specified jobs are ready, the command will enter the event loop, service events and wait for the first job to get ready. [para] The command returns the list of completed job IDs. If the optional variable [opt varname] is given, it will be set to the list of jobs in the [arg joblist] which are still pending. If the threadpool [arg tpool] is not found in the list of active thread pools, the command will throw error. [call [cmd tpool::cancel] [arg tpool] [arg joblist] [opt varname]] This command cancels the previously posted jobs given by the [arg joblist] to the pool [arg tpool]. Job cancellation succeeds only for job still waiting to be processed. If the job is already being executed by one of the worker threads, the job will not be cancelled. The command returns the list of cancelled job IDs. If the optional variable [opt varname] is given, it will be set to the list of jobs in the [arg joblist] which were not cancelled. If the threadpool [arg tpool] is not found in the list of active thread pools, the command will throw error. [call [cmd tpool::get] [arg tpool] [arg job]] This command retrieves the result of the previously posted [arg job]. Only results of jobs waited upon with the [cmd tpool::wait] command can be retrieved. If the execution of the script resulted in error, the command will throw the error and update the [var errorInfo] and [var errorCode] variables correspondingly. If the pool [arg tpool] is not found in the list of threadpools, the command will throw error. If the job [arg job] is not ready for retrieval, because it is currently being executed by the worker thread, the command will throw error. [call [cmd tpool::preserve] [arg tpool]] Each call to this command increments the reference counter of the threadpool [arg tpool] by one (1). Command returns the value of the reference counter after the increment. By incrementing the reference counter, the caller signalizes that he/she wishes to use the resource for a longer period of time. [call [cmd tpool::release] [arg tpool]] Each call to this command decrements the reference counter of the threadpool [arg tpool] by one (1).Command returns the value of the reference counter after the decrement. When the reference counter reaches zero (0), the threadpool [arg tpool] is marked for termination. You should not reference the threadpool after the [cmd tpool::release] command returns zero. The [arg tpool] handle goes out of scope and should not be used any more. Any following reference to the same threadpool handle will result in Tcl error. [call [cmd tpool::suspend] [arg tpool]] Suspends processing work on this queue. All pool workers are paused but additional work can be added to the pool. Note that adding the additional work will not increase the number of workers dynamically as the pool processing is suspended. Number of workers is maintained to the count that was found prior suspending worker activity. If you need to assure certain number of worker threads, use the [option minworkers] option of the [cmd tpool::create] command. [call [cmd tpool::resume] [arg tpool]] Resume processing work on this queue. All paused (suspended) workers are free to get work from the pool. Note that resuming pool operation will just let already created workers to proceed. It will not create additional worker threads to handle the work posted to the pool's work queue. [list_end] [section DISCUSSION] Threadpool is one of the most common threading paradigm when it comes to server applications handling a large number of relatively small tasks. A very simplistic model for building a server application would be to create a new thread each time a request arrives and service the request in the new thread. One of the disadvantages of this approach is that the overhead of creating a new thread for each request is significant; a server that created a new thread for each request would spend more time and consume more system resources in creating and destroying threads than in processing actual user requests. In addition to the overhead of creating and destroying threads, active threads consume system resources. Creating too many threads can cause the system to run out of memory or trash due to excessive memory consumption. [para] A thread pool offers a solution to both the problem of thread life-cycle overhead and the problem of resource trashing. By reusing threads for multiple tasks, the thread-creation overhead is spread over many tasks. As a bonus, because the thread already exists when a request arrives, the delay introduced by thread creation is eliminated. Thus, the request can be serviced immediately. Furthermore, by properly tuning the number of threads in the thread pool, resource thrashing may also be eliminated by forcing any request to wait until a thread is available to process it. [see_also tsv ttrace thread] [keywords thread threadpool] [manpage_end] thread3.0.1/doc/thread.man0000644003604700454610000005774314726633451014044 0ustar dgp771div[comment {-*- tcl -*- doctools manpage}] [manpage_begin thread n 3.0] [moddesc {Tcl Threading}] [titledesc {Extension for script access to Tcl threading}] [require Tcl 9.0] [require thread [opt 3.0]] [description] The [package thread] extension creates threads that contain Tcl interpreters, and it lets you send scripts to those threads for evaluation. Additionally, it provides script-level access to basic thread synchronization primitives, like mutexes and condition variables. [section COMMANDS] This section describes commands for creating and destroying threads and sending scripts to threads for evaluation. [list_begin definitions] [call [cmd thread::create] [opt -joinable] [opt -preserved] [opt script]] This command creates a thread that contains a Tcl interpreter. The Tcl interpreter either evaluates the optional [option script], if specified, or it waits in the event loop for scripts that arrive via the [cmd thread::send] command. The result, if any, of the optional [option script] is never returned to the caller. The result of [cmd thread::create] is the ID of the thread. This is the opaque handle which identifies the newly created thread for all other package commands. The handle of the thread goes out of scope automatically when thread is marked for exit (see the [cmd thread::release] command below). [para] If the optional [option script] argument contains the [cmd thread::wait] command the thread will enter into the event loop. If such command is not found in the [option script] the thread will run the [option script] to the end and exit. In that case, the handle may be safely ignored since it refers to a thread which does not exists any more at the time when the command returns. [para] Using flag [option -joinable] it is possible to create a joinable thread, i.e. one upon whose exit can be waited upon by using [cmd thread::join] command. Note that failure to join a thread created with [option -joinable] flag results in resource and memory leaks. [para] Threads created by the [cmd thread::create] cannot be destroyed forcefully. Consequently, there is no corresponding thread destroy command. A thread may only be released using the [cmd thread::release] and if its internal reference count drops to zero, the thread is marked for exit. This kicks the thread out of the event loop servicing and the thread continues to execute commands passed in the [option script] argument, following the [cmd thread::wait] command. If this was the last command in the script, as usually the case, the thread will exit. [para] It is possible to create a situation in which it may be impossible to terminate the thread, for example by putting some endless loop after the [cmd thread::wait] or entering the event loop again by doing an vwait-type of command. In such cases, the thread may never exit. This is considered to be a bad practice and should be avoided if possible. This is best illustrated by the example below: [example { # You should never do ... set tid [thread::create { package require Http thread::wait vwait forever ; # <-- this! }] }] The thread created in the above example will never be able to exit. After it has been released with the last matching [cmd thread::release] call, the thread will jump out of the [cmd thread::wait] and continue to execute commands following. It will enter [cmd vwait] command and wait endlessly for events. There is no way one can terminate such thread, so you wouldn't want to do this! [para] Each newly created has its internal reference counter set to 0 (zero), i.e. it is unreserved. This counter gets incremented by a call to [cmd thread::preserve] and decremented by a call to [cmd thread::release] command. These two commands implement simple but effective thread reservation system and offer predictable and controllable thread termination capabilities. It is however possible to create initially preserved threads by using flag [option -preserved] of the [cmd thread::create] command. Threads created with this flag have the initial value of the reference counter of 1 (one), and are thus initially marked reserved. [call [cmd thread::preserve] [opt id]] This command increments the thread reference counter. Each call to this command increments the reference counter by one (1). Command returns the value of the reference counter after the increment. If called with the optional thread [option id], the command preserves the given thread. Otherwise the current thread is preserved. [para] With reference counting, one can implement controlled access to a shared Tcl thread. By incrementing the reference counter, the caller signalizes that he/she wishes to use the thread for a longer period of time. By decrementing the counter, caller signalizes that he/she has finished using the thread. [call [cmd thread::release] [opt -wait] [opt id]] This command decrements the thread reference counter. Each call to this command decrements the reference counter by one (1). If called with the optional thread [option id], the command releases the given thread. Otherwise, the current thread is released. Command returns the value of the reference counter after the decrement. When the reference counter reaches zero (0), the target thread is marked for termination. You should not reference the thread after the [cmd thread::release] command returns zero or negative integer. The handle of the thread goes out of scope and should not be used any more. Any following reference to the same thread handle will result in Tcl error. [para] Optional flag [option -wait] instructs the caller thread to wait for the target thread to exit, if the effect of the command would result in termination of the target thread, i.e. if the return result would be zero (0). Without the flag, the caller thread does not wait for the target thread to exit. Care must be taken when using the [option -wait], since this may block the caller thread indefinitely. This option has been implemented for some special uses of the extension and is deprecated for regular use. Regular users should create joinable threads by using the [option -joinable] option of the [cmd thread::create] command and the [cmd thread::join] to wait for thread to exit. [call [cmd thread::id]] This command returns the ID of the current thread. [call [cmd thread::errorproc] [opt procname]] This command sets a handler for errors that occur in scripts sent asynchronously, using the [option -async] flag of the [cmd thread::send] command, to other threads. If no handler is specified, the current handler is returned. The empty string resets the handler to default (unspecified) value. An uncaught error in a thread causes an error message to be sent to the standard error channel. This default reporting scheme can be changed by registering a procedure which is called to report the error. The [arg procname] is called in the interpreter that invoked the [cmd thread::errorproc] command. The [arg procname] is called like this: [example { myerrorproc thread_id errorInfo }] [call [cmd thread::cancel] [opt -unwind] [arg id] [opt result]] This command requires Tcl version 8.6 or higher. [para] Cancels the script being evaluated in the thread given by the [arg id] parameter. Without the [option -unwind] switch the evaluation stack for the interpreter is unwound until an enclosing catch command is found or there are no further invocations of the interpreter left on the call stack. With the [option -unwind] switch the evaluation stack for the interpreter is unwound without regard to any intervening catch command until there are no further invocations of the interpreter left on the call stack. If [arg result] is present, it will be used as the error message string; otherwise, a default error message string will be used. [call [cmd thread::unwind]] Use of this command is deprecated in favour of more advanced thread reservation system implemented with [cmd thread::preserve] and [cmd thread::release] commands. Support for [cmd thread::unwind] command will disappear in some future major release of the extension. [para] This command stops a prior [cmd thread::wait] command. Execution of the script passed to newly created thread will continue from the [cmd thread::wait] command. If [cmd thread::wait] was the last command in the script, the thread will exit. The command returns empty result but may trigger Tcl error with the message "target thread died" in some situations. [call [cmd thread::exit] [opt status]] Use of this command is deprecated in favour of more advanced thread reservation system implemented with [cmd thread::preserve] and [cmd thread::release] commands. Support for [cmd thread::exit] command will disappear in some future major release of the extension. [para] This command forces a thread stuck in the [cmd thread::wait] command to unconditionally exit. The thread's exit status defaults to 666 and can be specified using the optional [arg status] argument. The execution of [cmd thread::exit] command is guaranteed to leave the program memory in the inconsistent state, produce memory leaks and otherwise affect other subsystem(s) of the Tcl application in an unpredictable manner. The command returns empty result but may trigger Tcl error with the message "target thread died" in some situations. [call [cmd thread::names]] This command returns a list of thread IDs. These are only for threads that have been created via [cmd thread::create] command. If your application creates other threads at the C level, they are not reported by this command. [call [cmd thread::exists] [arg id]] Returns true (1) if thread given by the [arg id] parameter exists, false (0) otherwise. This applies only for threads that have been created via [cmd thread::create] command. [call [cmd thread::send] [opt -async] [opt -head] [arg id] [arg script] [opt varname]] This command passes a [arg script] to another thread and, optionally, waits for the result. If the [option -async] flag is specified, the command does not wait for the result and it returns empty string. The target thread must enter it's event loop in order to receive scripts sent via this command. This is done by default for threads created without a startup script. Threads can enter the event loop explicitly by calling [cmd thread::wait] or any other relevant Tcl/Tk command, like [cmd update], [cmd vwait], etc. [para] Optional [option varname] specifies name of the variable to store the result of the [arg script]. Without the [option -async] flag, the command returns the evaluation code, similarly to the standard Tcl [cmd catch] command. If, however, the [option -async] flag is specified, the command returns immediately and caller can later [cmd vwait] on [opt varname] to get the result of the passed [arg script] [example { set t1 [thread::create] set t2 [thread::create] thread::send -async $t1 "set a 1" result thread::send -async $t2 "set b 2" result for {set i 0} {$i < 2} {incr i} { vwait result } }] In the above example, two threads were fed work and both of them were instructed to signalize the same variable "result" in the calling thread. The caller entered the event loop twice to get both results. Note, however, that the order of the received results may vary, depending on the current system load, type of work done, etc, etc. [para] Many threads can simultaneously send scripts to the target thread for execution. All of them are entered into the event queue of the target thread and executed on the FIFO basis, intermingled with optional other events pending in the event queue of the target thread. Using the optional [opt -head] switch, scripts posted to the thread's event queue can be placed on the head, instead on the tail of the queue, thus being executed in the LIFO fashion. [call [cmd thread::broadcast] [arg script]] This command passes a [arg script] to all threads created by the package for execution. It does not wait for response from any of the threads. [para] The sending thread (the one executing the thread::broadcast command) does not send the script to itself. [para] Each receiving thread is directed to place evaluation of the send script at the head of its event queue, stepping in front of any other events awaiting processing. [call [cmd thread::wait]] This enters the event loop so a thread can receive messages from the [cmd thread::send] command. This command should only be used within the script passed to the [cmd thread::create]. It should be the very last command in the script. If this is not the case, the exiting thread will continue executing the script lines past the [cmd thread::wait] which is usually not what you want and/or expect. [example { set t1 [thread::create { # # Do some initialization work here # thread::wait ; # Enter the event loop }] }] [call [cmd thread::eval] [opt {-lock mutex}] [arg arg] [opt {arg ...}]] This command concatenates passed arguments and evaluates the resulting script under the mutex protection. If no mutex is specified by using the [opt {-lock mutex}] optional argument, the internal static mutex is used. [call [cmd thread::join] [arg id]] This command waits for the thread with ID [arg id] to exit and then returns it's exit code. Errors will be returned for threads which are not joinable or already waited upon by another thread. Upon the join the handle of the thread has gone out of scope and should not be used any more. [call [cmd thread::configure] [arg id] [opt option] [opt value] [opt ...]] This command configures various low-level aspects of the thread with ID [arg id] in the similar way as the standard Tcl command [cmd fconfigure] configures some Tcl channel options. Options currently supported are: [option -eventmark] and [option -unwindonerror]. [para] When [option -eventmark] is provided with a value greater than 0 (zero), that value is the maximum number of asynchronously posted scripts that may be pending for the thread. [cmd {thread::send -async}] blocks until the number of pending scripts in the event loop drops below the [option -eventmark] value. [para] When [option -unwindonerror] is provided with a value of true, an error result in a script causes the thread to unwind, making it unavailable to evaluate additional scripts. [call [cmd thread::transfer] [arg id] [arg channel]] This moves the specified [arg channel] from the current thread and interpreter to the main interpreter of the thread with the given [arg id]. After the move the current interpreter has no access to the channel any more, but the main interpreter of the target thread will be able to use it from now on. The command waits until the other thread has incorporated the channel. Because of this it is possible to deadlock the participating threads by commanding the other through a synchronous [cmd thread::send] to transfer a channel to us. This easily extends into longer loops of threads waiting for each other. Other restrictions: the channel in question must not be shared among multiple interpreters running in the sending thread. This automatically excludes the special channels for standard input, output and error. [para] Due to the internal Tcl core implementation and the restriction on transferring shared channels, one has to take extra measures when transferring socket channels created by accepting the connection out of the [cmd socket] commands callback procedures: [example { socket -server _Accept 2200 proc _Accept {s ipaddr port} { after idle [list Accept $s $ipaddr $port] } proc Accept {s ipaddr port} { set tid [thread::create] thread::transfer $tid $s } }] [call [cmd thread::detach] [arg channel]] This detaches the specified [arg channel] from the current thread and interpreter. After that, the current interpreter has no access to the channel any more. The channel is in the parked state until some other (or the same) thread attaches the channel again with [cmd thread::attach]. Restrictions: same as for transferring shared channels with the [cmd thread::transfer] command. [call [cmd thread::attach] [arg channel]] This attaches the previously detached [arg channel] in the current thread/interpreter. For already existing channels, the command does nothing, i.e. it is not an error to attach the same channel more than once. The first operation will actually perform the operation, while all subsequent operation will just do nothing. Command throws error if the [arg channel] cannot be found in the list of detached channels and/or in the current interpreter. [call [cmd thread::mutex]] Mutexes are most common thread synchronization primitives. They are used to synchronize access from two or more threads to one or more shared resources. This command provides script-level access to exclusive and/or recursive mutexes. Exclusive mutexes can be locked only once by one thread, while recursive mutexes can be locked many times by the same thread. For recursive mutexes, number of lock and unlock operations must match, otherwise, the mutex will never be released, which would lead to various deadlock situations. [para] Care has to be taken when using mutexes in an multithreading program. Improper use of mutexes may lead to various deadlock situations, especially when using exclusive mutexes. [para] The [cmd thread::mutex] command supports following subcommands and options: [list_begin definitions] [call [cmd thread::mutex] [method create] [opt -recursive]] Creates the mutex and returns it's opaque handle. This handle should be used for any future reference to the newly created mutex. If no optional [opt -recursive] argument was specified, the command creates the exclusive mutex. With the [opt -recursive] argument, the command creates a recursive mutex. [call [cmd thread::mutex] [method destroy] [arg mutex]] Destroys the [arg mutex]. Mutex should be in unlocked state before the destroy attempt. If the mutex is locked, the command will throw Tcl error. [call [cmd thread::mutex] [method lock] [arg mutex]] Locks the [arg mutex]. Locking the exclusive mutex may throw Tcl error if on attempt to lock the same mutex twice from the same thread. If your program logic forces you to lock the same mutex twice or more from the same thread (this may happen in recursive procedure invocations) you should consider using the recursive mutexes. [call [cmd thread::mutex] [method unlock] [arg mutex]] Unlocks the [arg mutex] so some other thread may lock it again. Attempt to unlock the already unlocked mutex will throw Tcl error. [list_end] [para] [call [cmd thread::rwmutex]] This command creates many-readers/single-writer mutexes. Reader/writer mutexes allow you to serialize access to a shared resource more optimally. In situations where a shared resource gets mostly read and seldom modified, you might gain some performance by using reader/writer mutexes instead of exclusive or recursive mutexes. [para] For reading the resource, thread should obtain a read lock on the resource. Read lock is non-exclusive, meaning that more than one thread can obtain a read lock to the same resource, without waiting on other readers. For changing the resource, however, a thread must obtain a exclusive write lock. This lock effectively blocks all threads from gaining the read-lock while the resource is been modified by the writer thread. Only after the write lock has been released, the resource may be read-locked again. [para] The [cmd thread::rwmutex] command supports following subcommands and options: [list_begin definitions] [call [cmd thread::rwmutex] [method create]] Creates the reader/writer mutex and returns it's opaque handle. This handle should be used for any future reference to the newly created mutex. [call [cmd thread::rwmutex] [method destroy] [arg mutex]] Destroys the reader/writer [arg mutex]. If the mutex is already locked, attempt to destroy it will throw Tcl error. [call [cmd thread::rwmutex] [method rlock] [arg mutex]] Locks the [arg mutex] for reading. More than one thread may read-lock the same [arg mutex] at the same time. [call [cmd thread::rwmutex] [method wlock] [arg mutex]] Locks the [arg mutex] for writing. Only one thread may write-lock the same [arg mutex] at the same time. Attempt to write-lock same [arg mutex] twice from the same thread will throw Tcl error. [call [cmd thread::rwmutex] [method unlock] [arg mutex]] Unlocks the [arg mutex] so some other thread may lock it again. Attempt to unlock already unlocked [arg mutex] will throw Tcl error. [list_end] [para] [call [cmd thread::cond]] This command provides script-level access to condition variables. A condition variable creates a safe environment for the program to test some condition, sleep on it when false and be awakened when it might have become true. A condition variable is always used in the conjunction with an exclusive mutex. If you attempt to use other type of mutex in conjunction with the condition variable, a Tcl error will be thrown. [para] The command supports following subcommands and options: [list_begin definitions] [call [cmd thread::cond] [method create]] Creates the condition variable and returns it's opaque handle. This handle should be used for any future reference to newly created condition variable. [call [cmd thread::cond] [method destroy] [arg cond]] Destroys condition variable [arg cond]. Extreme care has to be taken that nobody is using (i.e. waiting on) the condition variable, otherwise unexpected errors may happen. [call [cmd thread::cond] [method notify] [arg cond]] Wakes up all threads waiting on the condition variable [arg cond]. [call [cmd thread::cond] [method wait] [arg cond] [arg mutex] [opt ms]] This command is used to suspend program execution until the condition variable [arg cond] has been signalled or the optional timer has expired. The exclusive [arg mutex] must be locked by the calling thread on entrance to this command. If the mutex is not locked, Tcl error is thrown. While waiting on the [arg cond], the command releases [arg mutex]. Before returning to the calling thread, the command re-acquires the [arg mutex] again. Unlocking the [arg mutex] and waiting on the condition variable [arg cond] is done atomically. [para] The [option ms] command option, if given, must be an integer specifying time interval in milliseconds the command waits to be signalled. Otherwise the command waits on condition notify forever. [para] In multithreading programs, there are many situations where a thread has to wait for some event to happen until it is allowed to proceed. This is usually accomplished by repeatedly testing a condition under the mutex protection and waiting on the condition variable until the condition evaluates to true: [example { set mutex [thread::mutex create] set cond [thread::cond create] thread::mutex lock $mutex while {} { thread::cond wait $cond $mutex } # Do some work under mutex protection thread::mutex unlock $mutex }] Repeated testing of the condition is needed since the condition variable may get signalled without the condition being actually changed (spurious thread wake-ups, for example). [list_end] [list_end] [section DISCUSSION] The fundamental threading model in Tcl is that there can be one or more Tcl interpreters per thread, but each Tcl interpreter should only be used by a single thread which created it. A "shared memory" abstraction is awkward to provide in Tcl because Tcl makes assumptions about variable and data ownership. Therefore this extension supports a simple form of threading where the main thread can manage several background, or "worker" threads. For example, an event-driven server can pass requests to worker threads, and then await responses from worker threads or new client requests. Everything goes through the common Tcl event loop, so message passing between threads works naturally with event-driven I/O, [cmd vwait] on variables, and so forth. For the transfer of bulk information it is possible to move channels between the threads. [para] For advanced multithreading scripts, script-level access to two basic synchronization primitives, mutex and condition variables, is also supported. [see_also tsv tpool ttrace [uri http://www.tcl.tk/doc/howto/thread_model.html]] [keywords thread events {message passing} synchronization mutex] [manpage_end] thread3.0.1/doc/man.macros0000644003604700454610000001144614726633451014047 0ustar dgp771div'\" The definitions below are for supplemental macros used in Tcl/Tk '\" manual entries. '\" '\" .AP type name in/out ?indent? '\" Start paragraph describing an argument to a library procedure. '\" type is type of argument (int, etc.), in/out is either "in", "out", '\" or "in/out" to describe whether procedure reads or modifies arg, '\" and indent is equivalent to second arg of .IP (shouldn't ever be '\" needed; use .AS below instead) '\" '\" .AS ?type? ?name? '\" Give maximum sizes of arguments for setting tab stops. Type and '\" name are examples of largest possible arguments that will be passed '\" to .AP later. If args are omitted, default tab stops are used. '\" '\" .BS '\" Start box enclosure. From here until next .BE, everything will be '\" enclosed in one large box. '\" '\" .BE '\" End of box enclosure. '\" '\" .CS '\" Begin code excerpt. '\" '\" .CE '\" End code excerpt. '\" '\" .VS ?version? ?br? '\" Begin vertical sidebar, for use in marking newly-changed parts '\" of man pages. The first argument is ignored and used for recording '\" the version when the .VS was added, so that the sidebars can be '\" found and removed when they reach a certain age. If another argument '\" is present, then a line break is forced before starting the sidebar. '\" '\" .VE '\" End of vertical sidebar. '\" '\" .DS '\" Begin an indented unfilled display. '\" '\" .DE '\" End of indented unfilled display. '\" '\" .SO '\" Start of list of standard options for a Tk widget. The '\" options follow on successive lines, in four columns separated '\" by tabs. '\" '\" .SE '\" End of list of standard options for a Tk widget. '\" '\" .OP cmdName dbName dbClass '\" Start of description of a specific option. cmdName gives the '\" option's name as specified in the class command, dbName gives '\" the option's name in the option database, and dbClass gives '\" the option's class in the option database. '\" '\" .UL arg1 arg2 '\" Print arg1 underlined, then print arg2 normally. '\" '\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages. .if t .wh -1.3i ^B .nr ^l \n(.l .ad b '\" # Start an argument description .de AP .ie !"\\$4"" .TP \\$4 .el \{\ . ie !"\\$2"" .TP \\n()Cu . el .TP 15 .\} .ta \\n()Au \\n()Bu .ie !"\\$3"" \{\ \&\\$1 \\fI\\$2\\fP (\\$3) .\".b .\} .el \{\ .br .ie !"\\$2"" \{\ \&\\$1 \\fI\\$2\\fP .\} .el \{\ \&\\fI\\$1\\fP .\} .\} .. '\" # define tabbing values for .AP .de AS .nr )A 10n .if !"\\$1"" .nr )A \\w'\\$1'u+3n .nr )B \\n()Au+15n .\" .if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n .nr )C \\n()Bu+\\w'(in/out)'u+2n .. .AS Tcl_Interp Tcl_CreateInterp in/out '\" # BS - start boxed text '\" # ^y = starting y location '\" # ^b = 1 .de BS .br .mk ^y .nr ^b 1u .if n .nf .if n .ti 0 .if n \l'\\n(.lu\(ul' .if n .fi .. '\" # BE - end boxed text (draw box now) .de BE .nf .ti 0 .mk ^t .ie n \l'\\n(^lu\(ul' .el \{\ .\" Draw four-sided box normally, but don't draw top of .\" box if the box started on an earlier page. .ie !\\n(^b-1 \{\ \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .el \}\ \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .\} .fi .br .nr ^b 0 .. '\" # VS - start vertical sidebar '\" # ^Y = starting y location '\" # ^v = 1 (for troff; for nroff this doesn't matter) .de VS .if !"\\$2"" .br .mk ^Y .ie n 'mc \s12\(br\s0 .el .nr ^v 1u .. '\" # VE - end of vertical sidebar .de VE .ie n 'mc .el \{\ .ev 2 .nf .ti 0 .mk ^t \h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n' .sp -1 .fi .ev .\} .nr ^v 0 .. '\" # Special macro to handle page bottom: finish off current '\" # box/sidebar if in box/sidebar mode, then invoked standard '\" # page bottom macro. .de ^B .ev 2 'ti 0 'nf .mk ^t .if \\n(^b \{\ .\" Draw three-sided box if this is the box's first page, .\" draw two sides but no top otherwise. .ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c .el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c .\} .if \\n(^v \{\ .nr ^x \\n(^tu+1v-\\n(^Yu \kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c .\} .bp 'fi .ev .if \\n(^b \{\ .mk ^y .nr ^b 2 .\} .if \\n(^v \{\ .mk ^Y .\} .. '\" # DS - begin display .de DS .RS .nf .sp .. '\" # DE - end display .de DE .fi .RE .sp .. '\" # SO - start of list of standard options .de SO .SH "STANDARD OPTIONS" .LP .nf .ta 5.5c 11c .ft B .. '\" # SE - end of list of standard options .de SE .fi .ft R .LP See the \\fBoptions\\fR manual entry for details on the standard options. .. '\" # OP - start of full description for a single option .de OP .LP .nf .ta 4c Command-Line Name: \\fB\\$1\\fR Database Name: \\fB\\$2\\fR Database Class: \\fB\\$3\\fR .fi .IP .. '\" # CS - begin code excerpt .de CS .RS .nf .ta .25i .5i .75i 1i .if t .ft C .. '\" # CE - end code excerpt .de CE .fi .if t .ft R .RE .. .de UL \\$1\l'|0\(ul'\\$2 .. thread3.0.1/doc/format.tcl0000644003604700454610000000131414726633451014053 0ustar dgp771div#!/usr/local/bin/tclsh set mydir [file dirname [info script]] lappend auto_path /usr/local/lib package req doctools doctools::new dt set wd [pwd] cd $mydir file rename html htm set code [catch { set f [open man.macros] set m [read $f] close $f foreach file [glob -nocomplain *.man] { set xx [file root $file] set f [open $xx.man] set t [read $f] close $f foreach {fmt ext dir} {nroff n man html html htm} { dt configure -format $fmt set o [dt format $t] set f [open $dir/$xx.$ext w] if {$fmt == "nroff"} { set o [string map [list {.so man.macros} $m] $o] } puts $f $o close $f } } } err] file rename htm html cd $wd if {$code} { error $err } exit 0 thread3.0.1/tests/0000755003604700454610000000000014731057540012450 5ustar dgp771divthread3.0.1/tests/ttrace.test0000644003604700454610000000000714726633451014635 0ustar dgp771divreturn thread3.0.1/tests/tsv.test0000644003604700454610000000416314726633451014176 0ustar dgp771divpackage require tcltest namespace import ::tcltest::* tcltest::loadTestedCommands package require thread set backends {gdbm lmdb} foreach b $backends { testConstraint have_$b [expr {$b in [tsv::handlers]}] } foreach backend $backends { set db "data" file delete -force $db set ::handle $backend:$db proc setup {} { tsv::array bind a $::handle } proc cleanup {} { tsv::array unbind a } test tsv-$backend-1.0 {tsv::array isboud} \ -constraints have_$backend \ -setup { setup } -body { tsv::array isbound a } -cleanup { cleanup } -result {1} test tsv-$backend-1.1 {tsv::array bind - empty} \ -constraints have_$backend \ -setup { setup } -body { tsv::array names b } -cleanup { cleanup } -result {} test tsv-$backend-1.2 {tsv::set} \ -constraints have_$backend \ -setup { setup } -body { tsv::set a Key Val } -cleanup { cleanup } -result {Val} test tsv-$backend-1.3 {tsv::get - previously set was persisted} \ -constraints have_$backend \ -setup { setup } -body { tsv::get a Key } -cleanup { cleanup } -result {Val} test tsv-$backend-1.4 {tsv::array names - previously set was persisted} \ -constraints have_$backend \ -setup { setup } -body { tsv::array names a } -cleanup { cleanup } -result {Key} test tsv-$backend-1.5 {tsv::exists - previously set exists} \ -constraints have_$backend \ -setup { setup } -body { tsv::exists a Key } -cleanup { cleanup } -result {1} test tsv-$backend-1.6 {tsv::pop - get previously set} \ -constraints have_$backend \ -setup { setup } -body { tsv::pop a Key } -cleanup { cleanup } -result {Val} test tsv-$backend-1.7 {tsv::exists - popped was removed} \ -constraints have_$backend \ -setup { setup } -body { tsv::exists a Key } -cleanup { cleanup } -result {0} file delete -force $db } test tsv-bug-c2dfd8b7ea {tsv::lset crash} -body { tsv::linsert mytsv mylist 0 A {X Y} tsv::lset mytsv mylist end 1 P } -result {A {X P}} ::tcltest::cleanupTests thread3.0.1/tests/tpool.test0000644003604700454610000000000714726633451014510 0ustar dgp771divreturn thread3.0.1/tests/tkt-84be1b5a73.test0000644003604700454610000000103314726633451015540 0ustar dgp771divpackage require tcltest namespace import ::tcltest::* tcltest::loadTestedCommands package require thread # This test used to segfault before commit f4c95731c0. test tkt-84be1b5a73 {Ticket 84be1b5a73} -body { set t [thread::create] set resultvar() {} trace add variable resultvar() write { unset -nocomplain resultvar() list} proc errorproc {tid einfo} {} thread::errorproc errorproc thread::send -async $t { error "" } resultvar() after 1000 { set forever 1 } vwait forever } -returnCodes 0 thread3.0.1/tests/thread.test0000644003604700454610000010760314731033512014620 0ustar dgp771div# Commands covered: thread # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Scriptics Corporation. # Copyright (c) 2002 ActiveState Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest namespace import ::tcltest::* tcltest::loadTestedCommands package require thread tcltest::testConstraint chanTransfer \ [expr {$::tcl_platform(platform) == "unix"}] set dummy [makeFile dummyForTransfer dummyForTransfer] set tcltest::mainThread [thread::id] proc ThreadReap {} { while {[llength [thread::names]] > 1} { foreach tid [thread::names] { if {$tid != $::tcltest::mainThread} { catch {thread::release -wait $tid} } } } llength [thread::names] } test thread-1.11 {no segfault on 2nd interpreter, bug [d4ba38d00d06ebba]} -body { # This behavior needs to be covered in a separate shell, because it doesn't expect # any other thread invocation before 2nd interpreter gets the thread::id (TSD), # but test-suite calls thread::id command (tcltest, all.tcl and thread.test): set fd [open [list |[info nameofexecutable] << [string map [list {$$load} [tcltest::loadScript]] { $$load; package require thread interp create ci set l {} ci eval {$$load; package require thread; thread::id} thread::send -async [thread::id] {lappend l ev-1}; update interp delete ci thread::send -async [thread::id] {lappend l ev-2}; update; # no SF here puts $l }] 2>@stderr] r] gets $fd } -cleanup { catch { close $fd } } -result {ev-1 ev-2} test thread-1.12 {no events in 2nd interpreter, bug [d4ba38d00d06ebba]} -setup { interp create ci } -body { set l {} thread::send -async [thread::id] {lappend l ev-1}; update ci eval {package require tcltest; tcltest::loadTestedCommands; package require thread} thread::send -async [thread::id] {lappend l ev-2}; update set l } -cleanup { interp delete ci } -result {ev-1 ev-2} test thread-2.0 {no global thread command} { info commands thread } {} test thread-2.84 {thread subcommands} -body { lsort [info commands thread::*] } -match glob -result {::thread::attach ::thread::broadcast *::thread::cond ::thread::configure ::thread::create ::thread::detach ::thread::errorproc ::thread::eval ::thread::exists ::thread::exit ::thread::id ::thread::join ::thread::mutex ::thread::names ::thread::preserve ::thread::release ::thread::rwmutex ::thread::send ::thread::transfer ::thread::unwind ::thread::wait} test thread-3.0 {thread::names initial thread list} { list [ThreadReap] [llength [thread::names]] } {1 1} test thread-4.0 {thread::create: create server thread} { ThreadReap set tid [thread::create] update set l [llength [thread::names]] ThreadReap set l } {2} test thread-4.1 {thread::create: create one shot thread} { ThreadReap thread::create {set x 5} foreach try {0 1 2 4 5 6} { # Try various ways to yield update after 10 set l [llength [thread::names]] if {$l == 1} { break } } ThreadReap set l } {1} test thread-4.2 {thread::create - create preservable thread} { ThreadReap set tid [thread::create -preserved] set c [thread::preserve $tid] thread::release -wait $tid ThreadReap set c } {2} test thread-4.3 {thread::create - release a thread} { ThreadReap set tid [thread::create {thread::release}] update after 10 set l [llength [thread::names]] ThreadReap set l } {1} test thread-4.4 {thread::create - create joinable thread} { ThreadReap set tid [thread::create -joinable {set x 5}] set c [thread::join $tid] ThreadReap set c } {0} test thread-4.5 {thread::create - join detached thread} { ThreadReap set tid [thread::create] thread::send -async $tid {after 1000 ; thread::release} catch {set res [thread::join $tid]} msg ThreadReap lrange $msg 0 2 } {cannot join thread} test thread-5.0 {thread::release} { ThreadReap set tid [thread::create {thread::release}] update after 10 set l [llength [thread::names]] ThreadReap set l } {1} test thread-6.0 {thread::unwind - simple unwind} { ThreadReap thread::create {thread::unwind} update after 10 set l [llength [thread::names]] ThreadReap set l } {1} test thread-6.1 {thread::unwind - blocked unwind} { ThreadReap thread::create {thread::unwind; vwait dummy} update after 10 set l [llength [thread::names]] ThreadReap set l } {2} test thread-7.0 {thread::exit} { ThreadReap set tid [thread::create -joinable {thread::exit}] set c [thread::join $tid] ThreadReap set c } {666} test thread-7.1 {thread::exit - # args} { set tid [thread::create] catch {thread::send $tid {thread::exit 1 0}} msg set msg } {wrong # args: should be "thread::exit ?status?"} test thread-7.2 {thread::exit - args} { set tid [thread::create] catch {thread::send $tid {thread::exit foo}} msg set msg } {expected integer but got "foo"} test thread-7.3 {thread::exit - status} { ThreadReap set tid [thread::create -joinable {thread::exit 0}] set c [thread::join $tid] ThreadReap set c } {0} test thread-8.0 {thread::exists - true} { ThreadReap set c [thread::exists [thread::create]] ThreadReap set c } {1} test thread-8.1 {thread::exists - false} { ThreadReap set tid [thread::create {set x 5}] update after 10 set c [thread::exists $tid] ThreadReap set c } {0} test thread-9.0 {thread::id} { expr {[thread::id] == $::tcltest::mainThread} } {1} test thread-9.1 {thread::id - args} { set x [catch {thread::id x} msg] list $x $msg } {1 {wrong # args: should be "thread::id"}} test thread-10.0 {thread::names args} { set x [catch {thread::names x} msg] list $x $msg } {1 {wrong # args: should be "thread::names"}} test thread-11.0 {thread::send - no args} { set x [catch {thread::send} msg] list $x $msg } {1 {wrong # args: should be "thread::send ?-async? ?-head? id script ?varName?"}} test thread-11.1 {thread::send - simple script} { ThreadReap set tid [thread::create] set five [thread::send $tid {set x 5}] ThreadReap set five } 5 test thread-11.2 {thread::send - bad thread id} { set tid dummy set x [catch {thread::send $tid {set x 5}} msg] list $x $msg } {1 {invalid thread handle "dummy"}} test thread-11.3 {thread::send - test TCL_ERROR return code} { ThreadReap set tid [thread::create] set c [thread::send $tid {dummy} msg] ThreadReap list $c $msg} {1 {invalid command name "dummy"}} test thread-11.4 {thread::send - test TCL_RETURN return code} { ThreadReap set tid [thread::create] set c [thread::send $tid {return} msg] ThreadReap list $c $msg } {2 {}} test thread-11.5 {thread::send - test TCL_BREAK return code} { ThreadReap set tid [thread::create] set c [thread::send $tid {break} msg] ThreadReap list $c $msg } {3 {}} test thread-11.6 {thread::send - asynchronous send} { ThreadReap set tid [thread::create] thread::send -async $tid {set x 5} update after 10 set five [thread::send $tid {set x}] ThreadReap set five } {5} test thread-11.7 {thread::send - async send with event-loop wait} { ThreadReap set res {} set tid [thread::create] thread::send -async $tid {set x 5} five vwait five lappend res $five; set five {} thread::send -async $tid {set x 5} [binary format cccc 0x66 0x69 0x76 0x65]; # five as byte array without str-rep. vwait five lappend res $five; set five {} ThreadReap set res } {5 5} test thread-11.7.1 {thread::send - sync send with var} { ThreadReap set res {} set tid [thread::create] thread::send $tid {set x 5} five lappend res $five; set five {} thread::send $tid {set x 5} [binary format cccc 0x66 0x69 0x76 0x65]; # five as byte array without str-rep. lappend res $five; set five {} ThreadReap set res } {5 5} test thread-11.8 {thread::send - send to self directly} { thread::send [thread::id] {set x 5} five set five } {5} test thread-11.9 {thread::send - send to self asynchronously} { set c [catch {thread::send -async [thread::id] {set x 5} five} msg] list $c $msg } {1 {can't notify self}} test thread-11.10 {thread::send - preserve errorInfo} { ThreadReap set len [llength [thread::names]] set tid [thread::create] set c [catch {thread::send $tid {set undef}} msg] ThreadReap list $c $msg $errorInfo } {1 {can't read "undef": no such variable} {can't read "undef": no such variable while executing "set undef" invoked from within "thread::send $tid {set undef}"}} test thread-11.11 {Thread_Send preserve errorCode} { ThreadReap set tid [thread::create] set c [catch {thread::send $tid {error ERR INFO CODE}} msg] ThreadReap list $c $msg $errorCode } {1 ERR CODE} test thread-11.12 {thread::send - self as target, queue order (bug [b5709ea906])} -body { # Short circuit sending to itself should consider order of already dispatched events, # so SYNC is expected after ASYNC (and possibly TMR-0) but definitely before IDLE, only # the HEAD event (synchronously sends to head of queue) is expected as first in the result, # (note the timer-generation may be retarded tcl-versions related, so TMR-0 can be delayed) ThreadReap set res {} set e [after 500 {lappend res TIMEOUT}] # after 0 {lappend res TMR-0} after idle {lappend res IDLE} thread::send -async [thread::id] {lappend res ASYNC} thread::send -async -head [thread::id] {lappend res AHEAD} thread::send -head [thread::id] {lappend res HEAD} thread::send [thread::id] {lappend res SYNC} # while {[llength $res] < 6 && "TIMEOUT" ni $res} { vwait res } after cancel $e ThreadReap set res } -match regexp -result {^HEAD(?:(?: TMR-0| AHEAD ASYNC){2} SYNC| AHEAD ASYNC SYNC TMR-0) IDLE$} test thread-12.0 {thread::wait} { ThreadReap set tid [thread::create {set x 5; thread::wait}] thread::send $tid {set x} five ThreadReap set five } {5} test thread-13.0 {thread::broadcast} { ThreadReap catch {unset tids} foreach i {1 2 3 4} { lappend tids [thread::create] } thread::broadcast {set x 5} update catch {unset r} foreach tid $tids { lappend r [thread::send $tid {if {[info exists x]} {set x}}] } ThreadReap set r } {5 5 5 5} test thread-13.1 {thread::broadcast no args} { set c [catch {thread::broadcast} msg] list $c $msg } {1 {wrong # args: should be "thread::broadcast script"}} test thread-14.0 {thread::eval - no arguments} { set c [catch {thread::eval} msg] list $c $msg } {1 {wrong # args: should be "thread::eval ?-lock ? arg ?arg...?"}} test thread-14.1 {thread::eval - bad arguments} { set c [catch {thread::eval -lock} msg] list $c $msg } {1 {wrong # args: should be "thread::eval ?-lock ? arg ?arg...?"}} test thread-14.2 {thread::eval - missing script argument} { set c [catch {thread::eval -lock dummy} msg] list $c $msg } {1 {wrong # args: should be "thread::eval ?-lock ? arg ?arg...?"}} test thread-14.3 {thread::eval - bad mutex handle} { set c [catch {thread::eval -lock dummy {set x 5}} msg] list $c $msg } {1 {no such mutex "dummy"}} test thread-14.4 {thread::eval - nested eval} { thread::eval {thread::eval {thread::eval {set x 5}}} } {5} test thread-15.0 {thread::configure - bad arguments} { set c [catch {thread::configure} msg] list $c $msg } {1 {wrong # args: should be "thread::configure threadlId ?optionName? ?value? ?optionName value?..."}} test thread-15.1 {thread::configure - bad thread id argument} { set c [catch {thread::configure dummy} msg] list $c $msg } {1 {invalid thread handle "dummy"}} test thread-15.2 {thread::configure - bad configure option} { set c [catch {thread::configure [thread::id] -dummy} msg] list $c $msg } {1 {bad option "-dummy", should be one of -eventmark, -unwindonerror or -errorstate}} test thread-15.3 {thread::configure - read all configure options} { ThreadReap set tid [thread::create] catch {unset opts} set opts [thread::configure $tid] ThreadReap expr {[llength $opts] % 2} } {0} test thread-15.4 {thread::configure - check configure option names} { ThreadReap set tid [thread::create] update after 10 catch {unset opts} array set opts [thread::configure $tid] ThreadReap array names opts } {-errorstate -unwindonerror -eventmark} test thread-15.5 {thread::configure - get one config option} { ThreadReap set tid [thread::create] update after 10 set l "" lappend l [thread::configure $tid -eventmark] lappend l [thread::configure $tid -unwindonerror] lappend l [thread::configure $tid -errorstate] ThreadReap set l } {0 0 0} test thread-15.6 {thread::configure - set -unwindonerror option} { ThreadReap set tid [thread::create] update after 10 thread::configure $tid -unwindonerror 1 set c [catch {thread::send $tid {set dummy}}] update after 10 set e [thread::exists $tid] ThreadReap list $c $e } {1 0} test thread-15.7 {thread::configure - set -errorstate option} { ThreadReap set tid [thread::create] update after 10 thread::configure $tid -errorstate 1 set c [thread::send $tid {set dummy} msg] ThreadReap list $c $msg } {1 {thread is in error}} test thread-15.8 {thread::configure - set -eventmark option} { ThreadReap set tid [thread::create] update after 10 thread::configure $tid -eventmark 1 thread::send -async $tid {after 2000} set t1 [clock seconds] thread::send -async $tid {after 2000} set t2 [clock seconds] ThreadReap expr {($t2 - $t1) >= 2} } {1} test thread-16.0 {thread::errorproc - args} { set x [catch {thread::errorproc foo bar} msg] list $x $msg } {1 {wrong # args: should be "thread::errorproc ?proc?"}} test thread-16.1 {thread::errorproc - errorproc change} { thread::errorproc foo thread::errorproc ThreadError set new [thread::errorproc] } {ThreadError} test thread-16.2 {thread::errorproc - async reporting} { set etid "" set emsg "" proc myerrproc {tid msg} { global etid emsg set etid $tid set emsg $msg } ThreadReap thread::errorproc myerrproc set tid [thread::create] update after 10 thread::send -async $tid {set x} after 10 update ThreadReap list [expr {$etid == $tid}] $emsg } {1 {can't read "x": no such variable while executing "set x"}} test thread-17.1 {thread::transfer - channel lists} {chanTransfer} { ThreadReap set tid [thread::create] set file [open $dummy r] set res [regexp $file [file channels]] thread::transfer $tid $file lappend res [regexp $file [file channels]] lappend res [regexp $file [thread::send $tid {file channels}]] thread::send $tid "close $file" ThreadReap set res } {1 0 1} test thread-17.2 {thread::transfer - target thread dying} {chanTransfer} { ThreadReap set tid [thread::create] set file [open $dummy r] thread::send -async $tid {after 3000 ; thread::release} catch {thread::transfer $tid $file} msg close $file ThreadReap set msg } {transfer failed: target thread died} test thread-17.3 {thread::transfer - clearing of fileevents} {chanTransfer} { proc _HandleIt_ {} { global gotEvents tid file if {$gotEvents == 0} { thread::transfer $tid $file # From now on no events should be delivered anymore, # restricting the end value to 1 } incr gotEvents } ThreadReap set tid [thread::create] set file [open $dummy r] set gotEvents 0 fileevent $file readable _HandleIt_ vwait gotEvents thread::send $tid "close $file" ThreadReap set gotEvents } {1} test thread-17.4 {thread::transfer - file - readable?} {chanTransfer} { ThreadReap set tid [thread::create] set file [open $dummy r] set res [regexp $file [file channels]] thread::transfer $tid $file set res [string length [thread::send $tid "read -nonewline $file"]] thread::send $tid "close $file" ThreadReap set res } [string length [::tcltest::viewFile dummyForTransfer]] test thread-17.5 {thread::transfer - file - closeable?} {chanTransfer} { set tid [thread::create] set file [open $dummy r] set res [regexp $file [file channels]] thread::transfer $tid $file set res [thread::send $tid "close $file"] ThreadReap set res } {} test thread-17.6 {thread::transfer - socket - readable?} {chanTransfer} { set tid [thread::create] set lsock "" proc accept {sock host port} {global lsock ; set lsock $sock} set listener [socket -server accept 0] set port [lindex [fconfigure $listener -sockname] 2] set socket [socket localhost $port] vwait lsock thread::transfer $tid $socket puts $lsock hello flush $lsock set res [thread::send $tid [list gets $socket]] thread::send $tid [list close $socket] ThreadReap close $listener close $lsock set res } {hello} test thread-17.7 {thread::transfer - socket - closeable?} {chanTransfer} { set tid [thread::create] set lsock "" proc accept {sock host port} {global lsock ; set lsock $sock} set listener [socket -server accept 0] set port [lindex [fconfigure $listener -sockname] 2] set socket [socket localhost $port] vwait lsock thread::transfer $tid $socket set res [thread::send $tid "regexp {$socket} \[file channels\]"] lappend res [thread::send $tid [list close $socket]] lappend res [thread::send $tid "regexp {$socket} \[file channels\]"] ThreadReap close $listener close $lsock set res } {1 {} 0} # We cannot test console channels, nor serials. Because we do not # really know if they are available, and under what names. But a pipe # channel, which uses the same type of code is something we can # do. Lucky us. test thread-17.8 {thread::transfer - pipe - readable?} {chanTransfer} { set tid [thread::create] set s [makeFile { puts hello flush stdout exit } pscript] set pipe [open "|[info nameofexecutable] $s" r] thread::transfer $tid $pipe thread::send $tid [list set pipe $pipe] set res [thread::send $tid {gets $pipe}] thread::send $tid {catch {close $pipe}} ThreadReap removeFile pscript set res } {hello} # The difference between 9 and 10 is the location of the close # operation. For 9 it is the original thread, for 10 the other # thread. 10 currently fails. It seems to be some signal stuff. test thread-17.9 {thread::transfer - pipe - closable?} {chanTransfer} { set tid [thread::create] set s [makeFile { fileevent stdin readable {if {[eof stdin]} {exit 0} ; gets stdin} vwait forever exit 0 } pscript] set pipe [open "|[info nameofexecutable] $s" r+] thread::send $tid [list set chan $pipe] thread::transfer $tid $pipe thread::send $tid {thread::detach $chan} thread::attach $pipe set res [regexp $pipe [file channels]] lappend res [close $pipe] lappend res [regexp $pipe [file channels]] ThreadReap removeFile pscript set res } {1 {} 0} test thread-17.10 {thread::transfer - pipe - closable?} {chanTransfer} { set tid [thread::create] set s [makeFile { fileevent stdin readable {if {[eof stdin]} {exit 0} ; gets stdin} vwait forever exit 0 } pscript] set pipe [open "|[info nameofexecutable] $s" r+] thread::send $tid [list set chan $pipe] thread::transfer $tid $pipe set res [thread::send $tid {regexp $chan [file channels]}] if {[catch { # This can fail on Linux, because there a thread cannot 'wait' on # the children of a different thread (in the same process). This # is for Linux < 2.4. For 2.4 it should be possible, but the # language is cautionary, so it may still fail. lappend res [thread::send $tid {close $chan}] }]} { # Fake a result lappend res {} } lappend res [thread::send $tid {regexp $chan [file channels]}] ThreadReap removeFile pscript set res } {1 {} 0} test thread-17.11a {thread::transfer - pipe - readable event - no transfer} { set tid [thread::create] set s [makeFile { after 5000 {exit 0} fileevent stdin readable { if {[eof stdin]} {exit 0} if {[gets stdin line] <0} return puts response } vwait forever exit 0 } pscript] ;# {} set pipe [open "|[info nameofexecutable] $s" r+] fconfigure $pipe -blocking 0 fileevent $pipe readable {read $pipe ; set cond ok} after 3000 {set cond timeout} puts $pipe tick ; flush $pipe vwait ::cond catch {close $pipe} removeFile pscript set cond } ok test thread-17.11b {thread::transfer - pipe - readable event - with transfer} { set tid [thread::create] set s [makeFile { after 5000 {exit 0} fileevent stdin readable { if {[eof stdin]} {exit 0} if {[gets stdin line] <0} return puts response } vwait forever exit 0 } pscript] ;# {} set pipe [open "|[info nameofexecutable] $s" r+] thread::transfer $tid $pipe thread::send $tid [list set chan $pipe] set cond [thread::send $tid { fconfigure $chan -blocking 0 fileevent $chan readable {read $chan ; set cond ok} after 3000 {set cond timeout} puts $chan tick ; flush $chan vwait ::cond catch {close $pipe} set cond }] ThreadReap removeFile pscript set cond } ok test thread-18.0 {thread::detach - args} { set x [catch {thread::detach} msg] list $x $msg } {1 {wrong # args: should be "thread::detach channel"}} test thread-18.1 {thread::detach - channel} { global fd set fd [open $dummy r] set r1 [regexp $fd [file channels]] thread::detach $fd set r2 [regexp $fd [file channels]] list $r1 $r2 } {1 0} test thread-18.2 {thread::attach - in different thread} { global fd ThreadReap set tid [thread::create] thread::send $tid "thread::attach $fd" set r1 [thread::send $tid "regexp $fd \[file channels\]"] thread::send $tid "thread::detach $fd" list $r1 } {1} test thread-18.3 {thread::attach - in same thread} { global fd thread::attach $fd set r1 [regexp $fd [file channels]] close $fd set r1 } {1} test thread-19.0 {thread::mutex - args} { set x [catch {thread::mutex} msg] list $x $msg } {1 {wrong # args: should be "thread::mutex option ?args?"}} test thread-19.1 {thread::mutex - command options} { set x [catch {thread::mutex dummy} msg] list $x $msg } {1 {bad option "dummy": must be create, destroy, lock, or unlock}} test thread-19.2 {thread::mutex - more command options} { set x [catch {thread::mutex create -dummy} msg] list $x $msg } {1 {wrong # args: should be "thread::mutex create ?-recursive?"}} test thread-19.3 {thread::mutex - create exclusive mutex} { set emutex [thread::mutex create] set c [regexp {mid[0-9]+} $emutex] thread::mutex destroy $emutex set c } {1} test thread-19.4 {thread::mutex - create recursive mutex} { set rmutex [thread::mutex create -recursive] set c [regexp {rid[0-9]+} $rmutex] thread::mutex destroy $rmutex set c } {1} test thread-19.5 {thread::mutex - lock/unlock exclusive mutex} { set emutex [thread::mutex create] thread::mutex lock $emutex thread::mutex unlock $emutex thread::mutex destroy $emutex } {} test thread-19.6 {thread::mutex - deadlock exclusive mutex} { set emutex [thread::mutex create] thread::mutex lock $emutex set x [catch {thread::mutex lock $emutex} msg] thread::mutex unlock $emutex thread::mutex destroy $emutex list $x $msg } {1 {locking the same exclusive mutex twice from the same thread}} test thread-19.7 {thread::mutex - lock invalid mutex} { set x [catch {thread::mutex lock dummy} msg] list $x $msg } {1 {no such mutex "dummy"}} test thread-19.8 {thread::mutex - lock/unlock recursive mutex} { set rmutex [thread::mutex create -recursive] thread::mutex lock $rmutex thread::mutex unlock $rmutex thread::mutex destroy $rmutex } {} test thread-19.9 {thread::mutex - deadlock exclusive mutex} { set rmutex [thread::mutex create -recursive] thread::mutex lock $rmutex set x [catch {thread::mutex lock $rmutex} msg] thread::mutex unlock $rmutex thread::mutex unlock $rmutex thread::mutex destroy $rmutex list $x $msg } {0 {}} test thread-19.10 {thread::mutex - destroy locked exclusive mutex} { set emutex [thread::mutex create] thread::mutex lock $emutex set x [catch {thread::mutex destroy $emutex} msg] thread::mutex unlock $emutex thread::mutex destroy $emutex list $x $msg } {1 {mutex is in use}} test thread-19.11 {thread::mutex - destroy locked recursive mutex} { set rmutex [thread::mutex create -recursive] thread::mutex lock $rmutex set x [catch {thread::mutex destroy $rmutex} msg] thread::mutex unlock $rmutex thread::mutex destroy $rmutex list $x $msg } {1 {mutex is in use}} test thread-19.12 {thread::mutex - lock exclusive between threads} { ThreadReap set tid [thread::create] set emutex [thread::mutex create] thread::send -async $tid [subst { thread::mutex lock $emutex after 2000 thread::mutex unlock $emutex }] update after 10 set time1 [clock seconds] thread::mutex lock $emutex set time2 [clock seconds] thread::mutex unlock $emutex ThreadReap thread::mutex destroy $emutex expr {($time2 - $time1) >= 1} } {1} test thread-19.13 {thread::mutex - lock args} { set x [catch {thread::mutex lock} msg] list $x $msg } {1 {wrong # args: should be "thread::mutex lock mutexHandle"}} test thread-19.14 {thread::mutex - unlock args} { set x [catch {thread::mutex unlock} msg] list $x $msg } {1 {wrong # args: should be "thread::mutex unlock mutexHandle"}} test thread-19.15 {thread::mutex - destroy args} { set x [catch {thread::mutex destroy} msg] list $x $msg } {1 {wrong # args: should be "thread::mutex destroy mutexHandle"}} test thread-20.0 {thread::rwmutex - args} { set x [catch {thread::rwmutex} msg] list $x $msg } {1 {wrong # args: should be "thread::rwmutex option ?args?"}} test thread-20.1 {thread::rwmutex - command options} { set x [catch {thread::rwmutex dummy} msg] list $x $msg } {1 {bad option "dummy": must be create, destroy, rlock, wlock, or unlock}} test thread-20.2 {thread::rwmutex - more command options} { set x [catch {thread::rwmutex create dummy} msg] list $x $msg } {1 {wrong # args: should be "thread::rwmutex create"}} test thread-20.3 {thread::rwmutex - more command options} { set x [catch {thread::rwmutex create dummy} msg] list $x $msg } {1 {wrong # args: should be "thread::rwmutex create"}} test thread-20.4 {thread::rwmutex - mutex handle} { set rwmutex [thread::rwmutex create] set c [regexp {wid[0-9]+} $rwmutex] thread::rwmutex destroy $rwmutex set c } {1} test thread-20.5 {thread::rwmutex - bad handle} { set x [catch {thread::rwmutex rlock dummy} msg] list $x $msg } {1 {no such mutex "dummy"}} test thread-20.6 {thread::mutex - destroy readlocked mutex} { set rwmutex [thread::rwmutex create] thread::rwmutex rlock $rwmutex set x [catch {thread::rwmutex destroy $rwmutex} msg] thread::rwmutex unlock $rwmutex thread::rwmutex destroy $rwmutex list $x $msg } {1 {mutex is in use}} test thread-20.7 {thread::mutex - destroy writelocked mutex} { set rwmutex [thread::rwmutex create] thread::rwmutex wlock $rwmutex set x [catch {thread::rwmutex destroy $rwmutex} msg] thread::rwmutex unlock $rwmutex thread::rwmutex destroy $rwmutex list $x $msg } {1 {mutex is in use}} test thread-20.8 {thread::rwmutex - readlock mutex} { ThreadReap set tid [thread::create] set rwmutex [thread::rwmutex create] thread::send -async $tid [subst { thread::rwmutex rlock $rwmutex after 1000 thread::rwmutex unlock $rwmutex }] update after 10 set time1 [clock seconds] thread::rwmutex rlock $rwmutex set time2 [clock seconds] thread::rwmutex unlock $rwmutex ThreadReap thread::rwmutex destroy $rwmutex expr {($time2 - $time1) < 1} } {1} test thread-20.9 {thread::rwmutex - writelock mutex} { ThreadReap set tid [thread::create] set rwmutex [thread::rwmutex create] thread::send -async $tid [subst { thread::rwmutex wlock $rwmutex after 2000 thread::rwmutex unlock $rwmutex }] update after 10 set time1 [clock seconds] thread::rwmutex rlock $rwmutex set time2 [clock seconds] thread::rwmutex unlock $rwmutex ThreadReap thread::rwmutex destroy $rwmutex expr {($time2 - $time1) >= 1} } {1} test thread-20.10 {thread::rwmutex - readlock args} { set x [catch {thread::rwmutex rlock} msg] list $x $msg } {1 {wrong # args: should be "thread::rwmutex rlock mutexHandle"}} test thread-20.11 {thread::rwmutex - writelock args} { set x [catch {thread::rwmutex wlock} msg] list $x $msg } {1 {wrong # args: should be "thread::rwmutex wlock mutexHandle"}} test thread-20.12 {thread::rwmutex - unlock args} { set x [catch {thread::rwmutex unlock} msg] list $x $msg } {1 {wrong # args: should be "thread::rwmutex unlock mutexHandle"}} test thread-20.13 {thread::rwmutex - destroy args} { set x [catch {thread::rwmutex destroy} msg] list $x $msg } {1 {wrong # args: should be "thread::rwmutex destroy mutexHandle"}} test thread-20.14 {thread::mutex - write-lock write-locked mutex} { set rwmutex [thread::rwmutex create] thread::rwmutex wlock $rwmutex set x [catch {thread::rwmutex wlock $rwmutex} msg] thread::rwmutex unlock $rwmutex thread::rwmutex destroy $rwmutex list $x $msg } {1 {write-locking the same read-write mutex twice from the same thread}} test thread-20.15 {thread::mutex - read-lock write-locked mutex} { set rwmutex [thread::rwmutex create] thread::rwmutex wlock $rwmutex set x [catch {thread::rwmutex rlock $rwmutex} msg] thread::rwmutex unlock $rwmutex thread::rwmutex destroy $rwmutex list $x $msg } {1 {read-locking already write-locked mutex from the same thread}} test thread-20.16 {thread::mutex - unlock not locked mutex} { set rwmutex [thread::rwmutex create] set x [catch {thread::rwmutex unlock $rwmutex} msg] thread::rwmutex destroy $rwmutex list $x $msg } {1 {mutex is not locked}} test thread-21.0 {thread::cond - args} { set x [catch {thread::cond} msg] list $x $msg } {1 {wrong # args: should be "thread::cond option ?args?"}} test thread-21.1 {thread::cond - command options} { set x [catch {thread::cond dummy} msg] list $x $msg } {1 {bad option "dummy": must be create, destroy, notify, or wait}} test thread-21.2 {thread::cond - more command options} { set x [catch {thread::cond create dummy} msg] list $x $msg } {1 {wrong # args: should be "thread::cond create"}} test thread-21.3 {thread::cond - cond handle} { set cond [thread::cond create] set c [regexp {cid[0-9]+} $cond] thread::cond destroy $cond set c } {1} test thread-21.4 {thread::cond - destroy args} { set x [catch {thread::cond destroy} msg] list $x $msg } {1 {wrong # args: should be "thread::cond destroy condHandle ?args?"}} test thread-21.5 {thread::cond - destroy bad handle} { set x [catch {thread::cond destroy dummy} msg] list $x $msg } {1 {no such condition variable "dummy"}} test thread-21.6 {thread::cond - notify args} { set x [catch {thread::cond notify} msg] list $x $msg } {1 {wrong # args: should be "thread::cond notify condHandle ?args?"}} test thread-21.7 {thread::cond - wait args} { set x [catch {thread::cond wait} msg] list $x $msg } {1 {wrong # args: should be "thread::cond wait condHandle ?args?"}} test thread-21.8 {thread::cond - wait bad handle} { set x [catch {thread::cond wait dummy} msg] list $x $msg } {1 {no such condition variable "dummy"}} test thread-21.9 {thread::cond - wait no mutex} { set cond [thread::cond create] set x [catch {thread::cond wait $cond} msg] thread::cond destroy $cond list $x $msg } {1 {wrong # args: should be "thread::cond wait condHandle mutexHandle ?timeout?"}} test thread-21.10 {thread::cond - wait bad mutex} { set cond [thread::cond create] set x [catch {thread::cond wait $cond dummy} msg] thread::cond destroy $cond list $x $msg } {1 {no such mutex "dummy"}} test thread-21.11 {thread::cond - wait unlocked mutex} { set cond [thread::cond create] set emutex [thread::mutex create] set x [catch {thread::cond wait $cond $emutex} msg] thread::cond destroy $cond thread::mutex destroy $emutex list $x $msg } {1 {mutex not locked or wrong type}} test thread-21.12 {thread::cond - wait locked mutex from wrong thread} { ThreadReap set tid [thread::create] set emutex [thread::mutex create] set cond [thread::cond create] thread::mutex lock $emutex thread::send -async $tid [subst -nocommands { set code [catch {thread::cond wait $cond $emutex 1000} result] }] update after 20 thread::cond notify $cond set c [thread::send $tid "set code"] set r [thread::send $tid "set result"] ThreadReap thread::cond destroy $cond thread::mutex unlock $emutex thread::mutex destroy $emutex list $c $r } {1 {mutex not locked or wrong type}} test thread-21.13 {thread::cond - wait recursive mutex} { set cond [thread::cond create] set rmutex [thread::mutex create -recursive] set x [catch {thread::cond wait $cond $rmutex} msg] thread::cond destroy $cond thread::mutex destroy $rmutex list $x $msg } {1 {mutex not locked or wrong type}} test thread-21.14 {thread::cond - wait readwrite mutex} { set cond [thread::cond create] set rwmutex [thread::rwmutex create] set x [catch {thread::cond wait $cond $rwmutex} msg] thread::cond destroy $cond thread::rwmutex destroy $rwmutex list $x $msg } {1 {mutex not locked or wrong type}} test thread-21.15 {thread::cond - regular timed wait} { ThreadReap set tid [thread::create] set emutex [thread::mutex create] set cond [thread::cond create] thread::send -async $tid [subst { thread::mutex lock $emutex thread::cond wait $cond $emutex 2000 thread::mutex unlock $emutex set test 1 }] update after 10 set time1 [clock seconds] thread::cond notify $cond set c [thread::send $tid "info exists test"] set time2 [clock seconds] ThreadReap thread::mutex destroy $emutex thread::cond destroy $cond list $c [expr {($time2 - $time1) < 2}] } {1 1} test thread-21.16 {thread::cond - delete waited variable} { ThreadReap set tid [thread::create] set emutex [thread::mutex create] set cond [thread::cond create] thread::send -async $tid [subst { thread::mutex lock $emutex thread::cond wait $cond $emutex 500 thread::mutex unlock $emutex }] update after 10 set c1 [catch {thread::cond destroy $cond} r1] thread::cond notify $cond after 1000 set c2 [catch {thread::cond destroy $cond} r2] ThreadReap thread::mutex destroy $emutex list $c1 $c2 $r1 $r2 } {1 0 {condition variable is in use} {}} test thread-22.1 {thread::send -command} { ThreadReap after 0 [list ::apply [list {} { set tid [thread::create] thread::send -command $tid {lindex hello} [list ::apply [list args { variable result set result $args } [namespace current]]] } [namespace current]]] vwait [namespace current]::result ThreadReap set result } hello test thread-bug-f32864afe3 {Hang in thread::eval -lock} -body { set mu [thread::mutex create] thread::eval -lock $mu {} thread::mutex destroy $mu ; # <- Bug f32864af hang } -result {} removeFile dummyForTransfer ::tcltest::cleanupTests thread3.0.1/tests/store-load.tcl0000644003604700454610000000325714726633451015241 0ustar dgp771div#!/usr/bin/env tclsh lappend auto_path . package require thread if {[llength $argv] != 3} { puts "Usage: $argv0 handle path times" puts { handle A persistent storage handle (see [tsv::array bind] manpage). path The path to file containing lines in the form of "keyval", where key is a single-word and val is everyting else. times The number of times to reload the data from persistent storage. This script reads lines of data from and stores them into the persistent storage described by . Values for duplicate keys are handled as a lists. The persistent storage engine is then stress-tested by reloading the whole store times. } exit 1 } lassign $argv handle path times ### Cleanup set filename [string range $handle [string first : $handle]+1 end] file delete -force $filename ### Load and store tab-separated values tsv::array bind a $handle set fd [open $path r] set start [clock milliseconds] set pairs 0 while {[gets $fd line] > 0} { if {[string index $line 0] eq {#}} { continue } set tab [string first { } $line] if {$tab < 0} { continue } set k [string range $line 0 $tab-1] set v [string range $line $tab+1 end] if {![tsv::exists a $k]} { incr pairs } tsv::lappend a $k $v } puts "Stored $pairs pairs in [expr {[clock milliseconds]-$start}] milliseconds" tsv::array unbind a tsv::unset a ### Reload set pairs 0 set iter [time { tsv::array bind a $handle set pairs [tsv::array size a] tsv::array unbind a tsv::unset a } $times] puts "Loaded $pairs pairs $times times at $iter" ## Dump file stats puts "File $filename is [file size $filename] bytes long" thread3.0.1/tests/French.txt0000644003604700454610000025303014726633451014426 0ustar dgp771div########################################################################### #Copyright 1999 The Internet Dictionary Project/Tyler Chambers #http://www.june29.com/IDP/ #This file is free to use and modify. Thank you for using the IDP. # #Approximately 1340 entries. 9/21/97 #Approximately 1884 entries. 1/7/98 #Appriximately 2160 entries. 3/8/98 #Approximately 3040 entries. 8/18/98 #Approximately 3250 entries. 2/19/99 ########################################################################### a un(e): ~ book = un livre. 2.(instead of number one) ~ year ago; il y a un an[Article] a un, une[Pronoun] aardvark orycte/rope[Noun] aardvark adverbe[Adverb] aardvarks tamanoirs aback etre deconcerte[Verb] aback to be taken ~ : etre deconcerte,interdit[Adverb] aback to be taken ~ :etre stupefait(e)[Adjective] abacterial non-bacte/rien[Adjective] abacus abaque,boulier (compteur)[Noun] abacus abaque[Noun] abacus boulier,compteur[Noun] abacuses abaques, bouliers abacuses abaques[Noun] abacuses bouliers, compteurs[Noun] abaft sur l'arrie\re, vers l'arrie\re[Adverb] abalone ormeau[Noun] abalones ormeaux[Noun] abandon abandon, laisser-aller[Noun] abandon abandonner[Verb] abandoned abandonne/[Adjective] abandoned abandonnes[Adjective] abandoned de/vergonde/[Adjective] abandonee abandoned, forsaken[Adjective] abandoner abandoneur[Adjective] abandoning abandonnant[Verb] abandonment abandon[Noun] abandonment abandonnement[Noun] abandonments abandons[Noun] abandons abandonnes[Verb] abase abaisser, humilier[Verb] abased humilie/ abasement abaissement, humiliation[Noun] abasements abaissement[Noun] abases mortifie, humilie, rabaisse[Verb] abash confondre, de/concerter[Verb] abashed confus(e), embarrasse(e)[Adjective] abashed deconcerte, confus, gene[Adjective] abasing humiliant[Adjective] abate diminuer[Verb] abate s'apaiser, se calmer[Verb] abated a diminue/[Verb] abatement diminution[Noun] abatement la suppression[Noun] abatements coupures abates se calme, s'apaise[Verb] abating faiblant[Adjective] abating faiblant[Adjective] abattoir abattoir[Noun] abbe abbe/[Noun] abberations aberrations[Noun] abbey abbaye (f)[Noun] abbey une abbaye[Noun] abbeys abbayes[Noun] abbot abbe ( d'un monastere)[Noun] abbot abbe/ abbot abbe/[Noun] abbot pere superieur[Noun] abbot abbe/[Noun] abbots abbe/s[Noun] abbreviate abbre/ger[Verb] abbreviate abre/ger[Verb] abbreviated abbre/gé[Verb] abbreviates s'abre\ge[Verb] abbreviating abre/geant[Verb] abbreviation abbre/viation[Noun] abbreviation abre/viation[Noun] abbreviation abreviation (f)[Noun] abbreviations abbre/viations[Noun] abbreviations abre/viations[Noun] abbreviator abre/viateur[Noun] abdicable abdiquable[Adjective] abdicate abdiquer[Verb] abdicate renoncer[Verb] abdicated abdique/[Adjective] abdication abdication[Verb] abdicator abdicateur[Adjective] abdomen abdomen (m)[Noun] abdomen abdomen[Noun] abdomens abdomens[Noun] abdominal abdominal[Adjective] abdominally abdominalement[Adverb] abduct enlever[Verb] abducted enlevé[Verb] abducting enlevant[Verb] abduction enlèvement[Noun] abductions enlèvements[Noun] abductor adducteur[Adjective] abductors adducteur[Adjective] abducts detourner[Verb] abeam par le travers[Adverb] abecedarian abécédaire[Noun] abed au lit[Noun] aberrance aberration (f)[Noun] aberrant aberrant, egare[Adjective] aberrantly de fac,on aberrante[Adverb] aberration aberration[Noun] aberration anomalie (f)[Noun] aberrations erreurs abet encourager (au crime)[Verb] abetment encouragement[Noun] abets secourirs abetted encouragea, soutient[Verb] abetter complice[Noun] abetting provoquant[Adjective] abettor aide, complice[Noun] abeyance in ~ (law): en desuetude; (matter) en suspens[Noun] abeyant en attente[Adjective] abhor avoir horreur de[Verb] abhorred abhorrait or abhorre/, de/testait or de/teste/[Verb] abhorrence aversion extreme, horreur[Noun] abhorrent odieux abhorrently de fac,on odieuse[Adverb] abhorring abhorrant[Adjective] abhors abhorrer[Verb] abide i can't ~ it/him : je ne peut pas le souffrir <or> supporter; to ~ by : observer, respecter[Verb] abided souffri[Adjective] abides tole\re, demeure, subsiste[Verb] abiding constant, e/ternel[Adjective] abilities talents[Noun] ability compe/tence ability competence (f); capacite (f); (skill) talent (m)[Noun] abiotic abiotique[Adjective] abject (poverty) sordid; (apology) plat(e)[Adjective] abjection abjection(f)[Noun] abjectly avec servilite/[Adjective] abjuration renoncement, apostasie (rel)[Noun] abjure abjurer[Verb] abjurer personne qui abjure ablation ablation ablative ablatif[Adjective] ablaze en feu ablaze en feu, en flammes[Adjective] able compe/tent(e) able competent(e); to be ~ to do sth : pouvoir faire qch, etre capable de faire qch[Adjective] able capable -to be able to e^tre capable de , pouvoir able to be ~: pouvoir[Verb] abler plus compétent(e)[Adjective] ablest le plus compe/tent[Adjective] abloom en fleur ablution ablution[Noun] ablutions ablutions[Noun] ably de fac,on compe/tente, habilement[Adjective] abnegate Renouncer à[Verb] abnegates renie, re/pudie, rejette[Verb] abnegation abne/gation[Noun] abnormal abnormal(e)[Adjective] abnormal anormal(e)[Adjective] abnormal anormal abnormalities anomalies, difformite/s[Noun] abnormality anomalie, malformation[Noun] abnormally anormalement[Adverb] aboard a\ bord abode of no fixed ~ :sans domicile fixe[Noun] abodes demeures, domiciles[Noun] aboil en train de bouillir[Verb] abolish abolir[Verb] abolish abroger, supprimer[Verb] abolishable qui peut e^tre aboli abolished aboli(es)[Verb] abolisher suppresseur[Adjective] abolishes abolit, abroge, supprime abolishment suppression, abolition, abrogation[Noun] abolition abolition abolition suppression[Noun] abolitionism abolitionnisme[Noun] abolitionist abolitionniste[Adjective] abolitionists abolitionnistes, antiesclavagistes (hist)[Noun] abominable abominable[Adjective] abominably abominablement, odieusement[Adverb] abominate abhorrer, exe/crer, abominer[Verb] abomination abomination[Noun] abominations abominations[Noun] aboriginal aborige\ne[Noun] aboriginally aboriginalement[Adverb] aborigine aborigene m/f[Noun] aborigines aborigines[Noun] abort faire avorter[Verb] aborted avorté[Verb] aborter avorteur/ avorteuse / faiseuse d'anges[Noun] aborting discontinuant[Adjective] abortion avortement abortion avortement (m)[Noun] abortionist avorteur[Noun] abortionists avorteurs abortions avortements[Noun] abortive manque(e)[Adjective] abortively en vain[Verb] aborts avorte, e/choue, abandonne[Verb] abound abonder abounding abondant[Adjective] about (approximatly)environ, a peu pres[Adjective] above au-dessus[Adjective] aboveboard re/gulier, correct[Adjective] aboveground au-dessus du sol, a\ la surface[Adjective] abovementioned ci-haut mentionné abovementioned mentionné ci-dessus[Adjective] abracadabra abracadabra[Verb] abradable qui peut s'e/rafler, qui peut s'e/roder[Adjective] abrade user en frottant, e/roder[Verb] abrasion frottement, e/corchure, abrasion[Noun] abrasions écorchures, égratignures[Noun] abrasive abrasif(ive)[Adjective] abrasives abrasifs[Noun] abreast de front[Adjective] abridge abreger[Verb] abridged abre/ge/[Verb] abridgement re/sume/[Noun] abridging raccourc,ant[Adjective] abroad a\ l'e/tranger, au loin[Adverb] abrogate abroger[Verb] abrogated abroge/, aboli[Verb] abrogation abrogation[Noun] abrupt abrupte[Adjective] abruptly brusquement[Adjective] abruptness abrupte[Noun] abscess abcès[Noun] abscesses abce\s[Noun] abscond s'enfuir[Verb] absconded s'enfuir (from, de)[Verb] absence absence[Noun] absences absences[Noun] absent absent[Adjective] absentee absentee[Noun] absenteeism absente/isme[Noun] absentees absentees[Noun] absently distraitement[Adverb] absentminded distrait[Adjective] absentmindedly d'un air distrait[Adverb] absentmindedly distraitement[Adverb] absentmindedness distraction[Noun] absinth absinthe[Noun] absinthe absinthe[Noun] absolute absolu[Adjective] absolutely absolument[Adverb] absolution absolution[Noun] absolutism absolutisme[Noun] absolve absoudre[Verb] absolved exone/re/[Adjective] absolving exon/erant[Adjective] absorb absorber, retenir, assimiler[Verb] absorbability absorbabilite/[Adjective] absorbable absorbable[Adjective] absorbant absorbant[Adjective] absorbed absorb/e[Adjective] absorbent absorbant(e)[Adjective] absorbing absorbant[Adjective] absorption absorbtion[Noun] abstain abstenir[Verb] abstained absteni[Adjective] abstemious frugal(e), sobre[Adjective] abstention abstention[Noun] abstentions abstentions[Noun] abstinence abstinence[Noun] abstinent sobre[Adjective] abstinently sobrement[Adverb] abstract abstrait[Adjective] abstract résumé, abrégé[Noun] abstraction distraction, abstraction[Noun] abstruse abstrus(e)[Adjective] absurd absurde[Adjective] absurdism absurdisme[Noun] absurdist absurdiste[Noun] absurdities absurdite/s[Noun] absurdity absurdite/[Noun] abundance abondance[Noun] abundant abondant[Adjective] abundantly abondamment[Adjective] abuse abus[Noun] abused abuse/[Verb] abused insulter[Verb] abusive abusif[Adjective] abusively abusivement[Adverb] abut etre contigu(ë) à[Verb] abuzz bourdonnant[Adjective] abysmal épouvantable, abominable[Noun] abysmally abominablement[Adverb] abyss abysse[Noun] abyss abi^me[Noun] abysses abysses[Noun] abysses abi^mes[Noun] acacia acacia[Noun] academic académique[Adjective] academical acade/mique[Adjective] academically acade/miquement[Adverb] academician acade/micien[Noun] academies academies[Noun] academism academisme[Noun] academy académie[Noun] acanthus acanthe[Noun] acanthuses acanthes[Noun] accede acce/der[Verb] accede consentir[Verb] accelerate acce/le/rer[Verb] accelerated accéléré[Adjective] acceleration acce/le/ration[Noun] accelerations acce/le/rations[Noun] accelerator acce/le/rateur[Noun] accelerators acce/le/rateurs[Noun] accelerometer acce/le/rome\tre[Noun] accelerometers acce/le/rome\tres[Noun] accent accent[Noun] accented accente/[Verb] accented accentue/ accents accents[Noun] accentual accentuelle[Adjective] accentually accentuellement[Adverb] accentuate accentuer[Verb] accentuated accentue/[Adjective] accentuation accentuation[Noun] accept accepter[Verb] acceptability acceptabilite/[Noun] acceptable acceptable[Adjective] acceptably convenablement[Adverb] acceptance acceptation[Noun] accepted accepte/[Verb] accepter accepteur[Noun] acceptor accepteur[Noun] access acce\s, acce/der (verb)[Noun] accessed accesse/[Verb] accessibility accessibilite/[Noun] accessible accessible[Adjective] accession accession[Noun] accessorial accessoire[Adjective] accessories accessoires[Noun] accessorize accessoriser[Verb] accessors accesseurs[Noun] accessory accessoire[Noun] accident accident[Noun] accidental accidentel[Adjective] accidentalism accidentalisme[Noun] accidentalist accidentaliste[Noun] accidentally accidentellement[Adverb] accidently accidentalement[Adverb] accidents accidents[Noun] acclaim acclamer[Verb] acclamation acclamation[Noun] acclimate acclimater[Verb] acclimated acclimate/[Adjective] acclimatize acclimater[Verb] accolade accolade[Noun] accolades accolades[Noun] accommodate accomoder[Verb] accommodated accommode/[Verb] accommodating obligeant(e)[Adjective] accommodation accomodation[Noun] accommodations accommodations[Noun] accompanied accompagne/[Adjective] accompanier accompagneur[Noun] accompanies accompanies[Verb] accompaniment accompagnement[Noun] accompaniments accompagnements[Noun] accompanist accompaniste[Noun] accompanists accompanistes[Noun] accompany accompagner, accompagner qqn (à)[Verb] accompanyist accompagnateur[Noun] accompanyists accompagnateurs[Noun] accomplice complice[Noun] accomplices complices[Noun] accomplish accomplir[Verb] accomplished accompli(e)[Adjective] accomplishment accomplissement[Noun] accomplishments accomplissements[Noun] accord accord[Noun] accordance in accordance with : en conformite/ avec accorder accordeur[Noun] accorders accordeurs[Noun] accordion accorde/on[Noun] accordionist accordionist accordioniste[Noun] accordionists accordionists accordionistes[Noun] accordions accorde/ons[Noun] accords accords[Noun] accost accoster[Verb] account compte[Noun] accountability responsibilité[Noun] accountable responsable[Adjective] accountant comptable[Noun] accounting comptabilité accouterment accoutrement[Noun] accredited accredite/[Verb] accrued accrue/[Verb] accruement accruement[Noun] accumulated accumule/[Verb] acetaminophen ace/taminophe\n[Noun] acetify acetifie/[Verb] acetone acetone[Noun] acid acide[Noun] acidic acidique[Adjective] admission aveu[Adverb] allergen allergene allergen allergene[Noun] allergic alergique[Adjective] allergies allergies allergies allergies[Noun] allergy allergie allergy allergie[Noun] alleviate apaiser, soulager[Verb] alleviated apaise/, apaise/e[Adjective] alley ruelle, alle/e alley ruelle, allée[Noun] alleys ruelles, alle/es alleys ruelles, alle/es[Noun] alliance alliance alliance alliance[Noun] alliances alliances alliances alliances[Noun] allied allie/, allie/e allied allie/, allie/e[Adjective] alligator alligator alligator alligator[Noun] alligators alligators alligators alligators[Noun] alliteration allite/ration alliteration allite/ration[Noun] alliterations allite/rations alliterations allite/rations[Noun] allocate attribuer[Verb] allocated attibue/, attribue/e[Adjective] allocation attribution allocation attribution[Noun] allocations attibutions allocations attributions[Noun] allocution allocution allocution attribution[Noun] allocution allocution[Noun] allot assigner[Verb] allow autoriser, permettre[Verb] allowable admissible[Adjective] allowance indemnité[Noun] allowed autorise/, autorise/e[Adjective] alloy alliage[Noun] alphabet alphabet[Noun] alphabetic alphabetique[Adjective] alphabetical alphabetique[Adjective] alphabetically alphabetiquement[Adverb] alphabetization alphabetisation[Noun] alphabetizations alphabetisations[Noun] alphabetize alphabetiser[Verb] alphabetized alphabetise[Adjective] alphabetizing alphabetizer[Verb] alphabets alphabets[Noun] alphamerical alphanumerique[Adjective] alphanumeric alphanumerique[Noun] alphanumerical alphanumerique[Adjective] alphanumerically alphanumeriquement[Adverb] alphanumerics alphanumerique[Adverb] alpine alpin[Adjective] alpinism alpinisme[Noun] alpinist alpiniste[Noun] already deja[Conjunction] also aussi[Conjunction] altercation altercation[Noun] altercations altercations[Noun] alternate alterner[Verb] alternated alterne[Adjective] alternately alternativement[Adverb] among parmi, entre[Preposition] amoral amoral[Adjective] amorous amoureux[Adjective] amorously amoureusement, avec amour[Adverb] amorphous amorphe[Adjective] amount s'elever. monter[Verb] amount somme, quantite, importance[Noun] amp ampere ; amplifier[Noun] ampere ampere[Noun] ampersand et commercial ; esperluette[Noun] amphetamine amphetamine[Noun] and et[Preposition] anyway En tout cas, de toute facon[Adverb] anywhere n'importe ou ; partout[Adverb] aorta aorte[Noun] apace rapidement[Adverb] apart a part, separe[Adjective] apartheid apartheid[Noun] apartment apartement, chambre[Noun] apathetic apathique[Adjective] apathy apathie, indifference[Noun] ape singe[Noun] ape singer[Verb] aperitif aperitif[Noun] aperture ouverture[Noun] apex sommet[Noun] aphid aphis; puceron[Noun] arrive arrivant[Verb] aspen abedul audit audit[Noun] auditorium auditorium[Noun] auditoriums auditoriums[Noun] audits audits[Verb] available disponible babble bavard[Verb] babbler bavardent babies be/be/s[Noun] baboon babouin baby be/be/[Noun] baccalaureate baccalaure/at[Noun] baccarat baccarat[Noun] bachelor ce/libataire[Noun] bachelors ce/le/bataires[Noun] bacilli bacilles (noun masculine)[Noun] bacillus bacille (noun masculine)[Noun] back en arriere, en retour backache douler de dos backbite calumnier backbone e/pine[Noun] background arriere-plan backgrounds arriere-plans backside derrie\re[Noun] backslide re/gresser[Verb] backup (computer) sauvegarde (feminine)[Noun] backward en arrie\re[Preposition] bacon lard bacteria bactérie bad mauvais, torve badge insigne badged insignée badgers blaireaux badinage badinage bag sac[Noun] bagatelle bagatelle bagatelles bagatelles baggage effets, colis bags fouilles, étuis, sacs baguette baguette bah bannir[Verb] bail caution bairn enfant (e/cossais)[Noun] bait leurre, eche bake faire cuire[Verb] baker boulanger bakeries boulangeries bakers boulangers bakery boulangerie bakeshop boulangerie[Noun] balance balance, équilibrer balconies balcons balcony balcon bald chauve, à ras baldhead chauve[Adjective] baldly ouvertement[Adverb] baldness calvitie[Noun] bale ballot baleen baleine balk déjouer[Verb] ball bal (dance), ballon (like for games) ballad ballade ballade ballade ballads ballades ballast ballast, lest ballet ballet balletic balletique balloon ballon, aérostat ballot ballot balls bals[Noun] ballyhoo publicite/[Noun] balm baume[Noun] bamboo enfant (italien)[Noun] bamboozle tricher[Verb] banana banane bananas bananes band bande, chapelle bandage bandage bandeau bandeau bandit brigand, forban, bandit bandits brigands, forbans, bandits bandleader chef d'orchestre[Noun] bandmaster chef d'orchestre[Noun] bane poison[Noun] banished banni[Adjective] barb barbe[Noun] barbarian barbare[Noun] barbarians barbares[Noun] barbarism barbarisme[Noun] barber barbier[Noun] barmaid serveuse[Noun] barman serveur[Noun] barracks casernes[Noun] beach plage[Noun] bear ours[Noun] bear supporter[Verb] bed lit[Noun] bedroom chambre (a coucher)[Noun] believe croire[Verb] betray trahir[Verb] bibliographic bibliographique[Adjective] bibliographies bibliographies[Noun] bibliography bibliographie[Noun] blackberry zarzamorra[Noun] bonjour hello book livre (m) boomerang boomerang (m) boxer (~ shorts) caleçon[Noun] boy garc,on[Noun] boys garc,ons[Noun] brain cerveaux[Noun] brood rimuginare, covare[Verb] broom balai broth bouillon build construire[Verb] building ba^timent[Noun] bye bon voyage, ciao[Preposition] cab taxi[Noun] cabal cabale[Noun] cabala cabale[Noun] cabalism cabalisme[Noun] cabalist cabaliste[Noun] cabalistic cabalistique[Adjective] caballero cavalier[Noun] cabaret cabaret[Noun] cabbage chou[Noun] cabbages choux[Noun] cabdriver chauffeur de taxi[Noun] cabin cabane[Noun] cabinet cabinet[Noun] cabinetmaker e/be/niste[Noun] cabinetmakers e/be/nistes[Noun] cabinets cabinets[Noun] cabins cabanes,(ships)cabines[Noun] cable ca^ble[Noun] cabled cablé[Adjective] cablegram ca^blogramme[Noun] cablegrams ca^blogrammes[Noun] cables ca^bles[Noun] cabling cablage[Noun] cabman cocher de fiacre[Noun] caboose caboose[Noun] cabotage cabotage[Noun] cabriolet cabriolet[Noun] cabs taxis[Noun] cacao cacao[Noun] cacciatore chasseur[Noun] cachalot cachalot[Noun] cache cachette[Noun] cachepot cachepot[Noun] caches cachettes[Noun] cackle caquet[Noun] cackled caquete/[Verb] cackles caquets[Noun] cackling caquetant[Verb] cacophony cacophonie[Noun] cacti cactus(plural)[Noun] cactus cactus (singular)[Noun] cad mufle[Noun] cadaver cadavre cadaverous terreux,[Adjective] caddies boi^tes a\ the/[Noun] caddy boii^te a\ the/[Noun] cadence cadence[Noun] cadet cadet, younger son[Noun] cadetship brevet de cadet[Noun] cadge mendier[Verb] cadger mendiant[Noun] cafe cafe/-restaurant[Noun] cafes cafe/-restaurants[Noun] cafeteria cafe/taria[Noun] cafeterias cafe/tarias[Noun] caffeine cafe/ine[Verb] caftan caftan[Noun] cage cage[Noun] cages cages[Noun] cahier copy book[Noun] cairn cairn[Noun] cairns cairns[Noun] caitiff la^che[Adjective] cajole cajoler[Verb] cajoler cajoleur[Noun] cajolery cajolerie[Noun] cake gâteau[Noun] cake ga^teau[Noun] calcium calcium[Noun] calculate calculer[Verb] calculated calculé calibrate calibrer[Verb] calibrated calibré[Adjective] calibration calibration[Noun] car voiture[Noun] carbonization carbonisation[Noun] carbonize carboniser[Verb] carbonized carbonise[Adjective] carbonless sans carbone[Adjective] carburetor carburateur[Noun] carburetors carburateurs[Noun] carburization carburation[Noun] carburize carburer[Verb] card carte[Noun] cardamom cardamone[Noun] cardiac cardiaque[Adjective] cardigan cardigan[Noun] cardioid cardioide[Noun] cardioids cardioides[Noun] care attention[Noun] care care[Noun] cared attentionne[Adjective] career cariere[Noun] careful attentionne[Adjective] carefully avec attention[Adjective] cat le chat[Noun] cell cellule[Noun] cellular cellulaire[Adjective] chance hasard cherries les cerises[Noun] church e/glise[Noun] churches e/glises[Noun] cloak manteau[Noun] cloaks manteaux[Noun] clock horloge[Noun] clockmaker horloger[Noun] clockwise dans le sens des aigu.illes d'une montre cloister cloitre[Noun] clone clone[Noun] cloud le nuage c'mon ben voyons coal charbon (masc.)[Noun] computer ordinateur[Noun] computers ordinateurs[Noun] comrades amis[Noun] concealed e/touffe/ conjuring escamotage[Verb] contemplate contempler[Verb] contemplate envisager[Verb] contemplate pre/voir[Verb] contemplates envisage[Verb] contemplation contemplation[Noun] contemplation me/ditation[Noun] contemplation recueillement[Noun] contemplations contemplations[Noun] contemplations me/ditations[Noun] contemplative contemplatif[Adjective] contemporaneous contemporain[Adjective] contemporaneously en me^me temps que [Adverb] contemporaries contemporains[Noun] contemporaries de la me^me ge/ne/ration[Adjective] contemporary contemporain[Adjective] contemporary de la me^me ge/ne/ration[Adjective] contempt de/dain[Noun] contempt me/pris[Noun] contemptible indigne[Adjective] contemptible me/prisable[Adjective] contemptibly avec me/pris[Adverb] contemptuous de me/pris[Adjective] contemptuous me/prisant[Adjective] contemptuously avec de/dain[Adverb] contemptuously avec me/pris[Adverb] contend combattre[Verb] contend disputer[Verb] contend lutter[Verb] contender candidat[Noun] contender challenger[Noun] contender concurrent[Noun] contenders candidats[Noun] contenders challengers[Noun] contenders concurrents[Noun] contending concurrents[Adjective] contending oppose/es[Adjective] contends dispute[Verb] contends lutte[Verb] content contenter[Verb] content satisfaire[Verb] content satisfait[Adjective] contented content[Adjective] contented satisfait[Adjective] contentedly avec contentement[Adverb] contentedness contentement[Noun] contention dispute[Noun] contention e/mulation[Noun] contention lutte[Noun] contentions disputes[Noun] contentions e/mulations[Noun] contentions luttes[Noun] contentious contentieux[Adjective] contentious querelleur[Adjective] contentment contentement[Noun] contents contenu[Noun] contents table de matie\res[Noun] contest combat[Noun] contest concours[Noun] contest contester[Verb] contestant combattant[Noun] contestant concurrent[Noun] cot lit d'enfant[Noun] coterie coterie[Noun] cotillion cotillon[Noun] cotillon cotillon[Noun] cottage chaumie\re[Noun] cottager paysan[Noun] couch couche[Noun] cough tousser[Verb] coughs toux[Noun] count compter[Verb] countenance visage[Noun] counteract neutraliser[Verb] counterbalance contrepoids[Noun] counterfeit contrefait[Adjective] countermand contremander[Verb] countermarch contremarche[Noun] counterplot contre-ruse[Noun] counterpoint contrepoint[Noun] counterpoise contre-balancer[Verb] counterweight contrepoids[Noun] countess comtesse[Noun] countless innombrable[Adjective] country pays[Verb] countryman concitoyen[Noun] countrywide concitoyenne county comte/[Noun] couple couple[Noun] couplet distique[Noun] coupon coupon[Noun] courage courage[Noun] courageous courageux[Adjective] courageously cougrageusement[Adjective] courier courrier[Noun] course cours[Noun] courser coursier[Noun] court cour[Noun] courteous courtois[Adjective] courteously courtoisement[Adverb] courteousness courtoisie[Noun] courtesy courtoisie courthouse palais de justice[Noun] courtier courtisan[Noun] courtliness e/le/gance[Adjective] courtly e/le/gant[Adjective] courtmartial conseil de guerre[Noun] courtroom salle d'audience[Noun] courtship cour[Noun] cousin cousin[Noun] cove anse[Noun] covenant convention[Noun] cover couvrir[Verb] covert cache/[Adjective] covet covoiter[Adjective] covetous avide[Adjective] covetously avidement[Adjective] cow la moo cowetta[Noun] cow la vache[Noun] coward la^che[Noun] cowardice la^chete/ cowardly la^che[Adjective] cower se blottir[Verb] cowherd vacher[Noun] cowl capuchon[Noun] coxcomb petit-mai^tre[Noun] coy farouche[Adjective] coyly modestement[Adverb] coyness re/serve[Noun] coyote coyote[Noun] cozily confortablement[Adverb] cozy confortable crab cancre[Noun] crabapple pomme sauvage[Noun] crabbed maussade[Adjective] crack fente[Noun] cracker pe/tard[Noun] crackle craqueter[Verb] cradle berceau[Noun] craft fourberie[Noun] craftily astucieusement[Adverb] crag rocher escarpe/[Noun] cram fourrer[Verb] cramp crampe[Noun] cranberry airelle coussinette[Noun] crane grue[Noun] cranium cra^ne[Noun] crank manivelle[Noun] crankiness humeur difficile[Noun] cranky d'humeur difficile[Adjective] crape cre^pe[Noun] crash retentir[Verb] crate caisse a\ claire-voie[Noun] crater crate\re[Noun] crave de/sirer ardemment[Verb] craven poltron[Adjective] crawl ramper[Verb] crayfish e/crevisse[Noun] crayon pastel[Noun] craze manie[Noun] crazily follement[Adverb] crazy fou[Adjective] creak grincer[Verb] cream cr\eme[Noun] creamy cre/meux[Adjective] crease plisser[Verb] create cre/er[Verb] creation cre/ation creator cre/ateur[Noun] creature cre/ature[Noun] credence croyance[Noun] credential certificat[Noun] credit cre/dit[Noun] creditable estimable creditably honourablement[Adverb] creditor cre/ancier[Noun] credo crois[Verb] credulity cre/dulite/[Noun] credulous cr/edule[Adjective] credulously cr/edulement[Adverb] creed credo[Noun] creek crique[Noun] creep ramper[Verb] creeps chair de poule[Noun] cremate incin/erer[Verb] cut couper[Verb] cute mignon, charmant, adorable[Adjective] cute mignonne[Adjective] cuteness gentillesse, charme[Noun] cutoffs limite, seuil[Noun] cutout forme a\ de/couper[Noun] cuts e/conomies, re/duction de budget[Noun] cutter couteau (de de/coupage)[Noun] cutting d/ecoupe, de/coupage[Noun] cyanate cyanante[Noun] cyanide cyanure[Noun] cybernetic cyberne/tique[Adjective] cybernetician cyberne/ticien[Noun] cybernetics cyberne/tique[Noun] cycle cycle[Noun] cyclic cyclique[Adjective] cyclical cyclique[Adjective] cyclist cycliste[Noun] cyclists cyclistes[Noun] cycloid cycloi.de[Noun] cycloidal cycloi.dal[Adjective] cyclone cyclone[Noun] cyclonic cyclonique[Adjective] cyclopean cyclope/en[Adjective] cyclotron cyclotron[Noun] cylinder cylindre[Noun] dad papa[Noun] daddies papas[Noun] daddy papa[Noun] dads papas[Noun] daffy barjot[Adjective] daft barje[Adjective] dagger dague (une)[Noun] dahlia dahlia[Noun] dahlias dahlias[Noun] daily quotidien daintier plus délicat dainty délicat dairy laitier dalmatian dalmatien[Adjective] dalmatians dalmatiens[Noun] dam barrage[Noun] damage abimer[Verb] damage de/ga^t[Noun] damage endommagement damage endommager[Verb] damaged endommage/[Adjective] damaged endommagé[Adjective] damager endommageur damagers endommageurs damages de/ga^ts[Noun] damaging endommageant dame dame dammit merde alors damnation damnation[Noun] damned damne/[Adjective] damp humide[Adjective] dampen humidifier[Verb] dampened humidifie/ dampness humidite/[Noun] dams barrages[Noun] dance danse dancer danceur dancers danceurs dancing danser[Verb] dandelion pissenlit dandelions pissenlits dandies dandys[Noun] dandruff pelicule[Noun] danger danger[Noun] dangerous dangereux[Adjective] d'art d'art day jour[Noun] daybreak aube[Noun] daylight lumiere du jour[Noun] days jours[Noun] deactivate de/sactiver[Verb] deactivation de/sactivation[Noun] dead mort[Adjective] deaf sourd[Adjective] deaths morts deep profond[Adjective] density densite/[Noun] deserve meriter[Verb] d'etat d'état d'etre d'être device pe/riph/erique[Noun] device pe/riphe/rique[Noun] dictated dicté[Verb] dictates dicte[Verb] dictation dictée[Noun] dictations dictées[Noun] dictionaries dictionnaires[Noun] dictionary dictionnaire[Noun] did a fait[Verb] die mourir[Verb] died mort[Verb] diesel diesel[Noun] diet diète[Noun] dietetically diététiquement[Adverb] diets diètes[Noun] different différent[Adjective] difficulties difficultés[Noun] difficulty difficulté[Noun] dig creuser[Verb] digested digéré[Verb] dignitaries dignitaires[Noun] dignities dignités[Noun] dignity dignité[Noun] dilate dilater[Verb] dilated dilaté[Verb] doctor docteur[Noun] document document[Noun] d'oeuvre d'oeuvre dog chien/ne[Noun] doggie chien/ne[Noun] dogs chiens[Noun] drink boire[Verb] drinks boissons[Noun] drive conduire[Verb] driver conducteur[Noun] drizzle bruiner[Verb] dry se/cher[Verb] duck canard[Noun] each chaque eagle aigle[Noun] eagles aigles[Noun] eaglet aiglon[Noun] ear oreille[Noun] earache mal d'oreille[Noun] eardrum tympan[Noun] eardrums tympans[Noun] earlobe lobe d'oreille[Noun] early to^t[Adjective] earn gagner[Verb] earning gagner[Verb] earphones e/couteurs[Noun] earring boucle d'oreille[Noun] earrings boucles d'oreille[Noun] ears oreilles[Noun] earth terre[Noun] earthquake tremblement de terre[Noun] earthquakes tremblements de terre[Noun] earths terres[Noun] earthworm ver de terre[Noun] earthworms vers de terre[Noun] earwax serumen[Noun] ease facilite/[Noun] easel chevalet[Noun] easier plus facile[Adjective] easiest le plus facile[Adjective] easily facilement[Adverb] easiness facilite/[Noun] east est[Noun] easter Pa^ques[Noun] easy facile[Adjective] eat manger[Verb] eatable comestible[Adjective] eats manger[Verb] ebony e/be\ne[Noun] eccentric excentrique[Adjective] eccentricity excentricite/[Noun] ecclesiastic eccle/siastique[Noun] echo e/cho[Noun] eclipse e/clipse[Noun] ecologic e/cologique[Adjective] ecologist e/cologiste[Noun] ecology e/cologie[Noun] economics econom'ica[Noun] ecru e/cru[Adjective] eight huit[Adverb] eighteen dix-huit[Adverb] eighteenth dix-huitie\me[Adjective] eightfold huit fois[Adverb] eighth huitie\me[Adjective] eighties les anne/es quatre-vingt (f)[Noun] eightieth quatre-vingtie\me[Adjective] eighty quatre-vingt[Adverb] eightyfold quatre-vingt fois[Adverb] einsteinium einsteinium (m)[Noun] either soit[Adverb] ejaculate e/jaculer[Verb] ejaculated e/jacule/[Adjective] ejaculates e/jacule[Verb] ejaculating e/jaculant[Adjective] ejaculation e/jaculation (f)[Noun] ejaculations e/jaculations (f)[Noun] ejaculatory e/jaculatoire[Adjective] eject e/jecter[Verb] ejectable e/jectable[Adjective] ejecting e/jectant[Verb] ejection e/jection (f)[Noun] ejector e/jecteur (m)[Noun] ejectors e/jecteurs (m)[Noun] elaborate e/laborer[Verb] elaborated e/labore/ (m), e/labore/e (f)[Adjective] elaborates e/labore[Verb] elaborating e/laborant[Adjective] elaboration e/laboration (f)[Noun] elaborations e/laborations (f)[Noun] elevator ascenseur[Noun] eleven onze[Adjective] eleventh onzie\me[Noun] eliminate e/liminer[Verb] end fin[Noun] environment ambiente[Noun] environmental ambiental[Adjective] envoy enviado[Noun] envy envidia[Noun] envy envidiar[Verb] escalator escalier roulant[Noun] establish constater[Verb] event occasion[Noun] eventual final[Adjective] eventually finallement[Adverb] ever toujours[Adverb] evergreen permanent[Adjective] everlasting permanent[Adjective] every chaque[Pronoun] everywhere partout[Conjunction] eviction mise a` l' e'cart[Noun] evidence preuve[Noun] exclaim s'exclaimer[Verb] fable fable[Noun] fables fables[Noun] fabric tissu[Noun] fabricant fabricant[Noun] fabricate fabriquer[Verb] fabricated fabrique/[Pronoun] fabricates fabrique[Verb] fabricating fabriquant[Verb] fabrication invention(s), fabulation; fait, forge(e) de toutes pieces[Noun] fabrications fabrications[Noun] fabricator fabricant[Noun] fabricators fabricants[Noun] fabrics tissus[Noun] fabulist fabuliste (m)[Noun] fabulous fabuleux(euse); formidable[Adjective] facade fac,ade[Noun] facades fac,ades[Noun] face visage, figure; expression; (of clock) cadran; (of building) facade[Noun] faceless sans face[Noun] faceplate face avant (f),panneau avant (m)[Noun] facet facette[Noun] facetious facétieux[Adjective] facetious plaisant[Adjective] facetiously facétieusement[Adverb] facial facial[Adjective] facies facie\s (m)[Noun] facile facile[Adjective] facilitate faciliter[Verb] facilitated facilite/[Pronoun] facilitates facilite[Verb] facilitating facilitant[Verb] facilities instalations[Noun] facility usine (f), e/tablissement (m)[Noun] facing face a, en face de[Preposition] facsimile (document) telecopie; (machine) telecopieur[Noun] fact fait[Noun] faction faction[Noun] factor facteur[Noun] factorial factoriel factorials factorielles (f)[Noun] factories usines (f)[Noun] factorization factorisation[Noun] factorizations factorisations[Noun] factorize factoriser[Verb] factorized factorisé[Adjective] factors facteurs (m)[Noun] factory usine (m) facts faits[Noun] factual factuel (m),factuelle (f)[Adjective] facultative facultatif[Adjective] facultatively facultativement[Adverb] faculties faculte/s (f)[Noun] faculty faculté fad affaiblir, atte/nuer[Verb] fade se faner[Verb] faded affaibli, atte/nue/[Adjective] fader atte/nuateur (m)[Noun] faders atte/nuateurs (m)[Noun] fading affaiblissement (m), atte/nuation (f)[Noun] faery fe/e[Noun] faience fai.ence fail échouer[Verb] faint s'e/vanouir[Verb] faintly faiblement[Adverb] fair juste[Adjective] fairly e/quitablement[Adverb] fairy fe/e[Noun] faith foi[Noun] faithful fide\le[Adjective] faithfully fide\lement[Adverb] fashion mode[Noun] fashionable a\ la mode[Adjective] fast rapide[Adjective] fasten attacher[Verb] fastener fermeture[Noun] fastidious exigeant[Adjective] fat gros[Adjective] fatal mortel[Adjective] fatalism fatalisme[Noun] fatality victime[Noun] fatally mortellement[Adverb] fate destin[Noun] fish poisson[Noun] fishable pêchable[Adverb] fishbowl bôl à poisson[Noun] fished pêché[Verb] fisher pêcheur[Noun] fisheries poissonneries[Noun] fisherman pêcheur[Noun] fishermen pêcheurs[Noun] fishers pêcheurs[Noun] fishery poissonnerie[Noun] fishes poissons[Noun] fishing à la pêche fishtail queue-de-poisson[Noun] fission fision[Noun] fissionable fisionable[Adverb] fissure fissure[Noun] fist poing[Noun] fisted poingé[Verb] fistful poingée[Noun] five cinq[Adverb] fivefold cinq fois[Adverb] fix re/parer[Verb] fixation fixation (f)[Noun] fixations fixations (f)[Noun] fixity fixite/ (f)[Noun] fixture support (m)[Noun] fixtures supports (m)[Noun] fjord fjord (m)[Noun] fjords fjords (m)[Noun] flight le vol[Noun] floppy disquette[Noun] fluently couramment[Adverb] foot pied[Noun] football football[Noun] forget oublier[Verb] forgetful oublieux[Adjective] forgetfulness manque de me/moire[Noun] forgivable excusable[Adjective] forgivably de fac,on excusable[Adverb] forgive pardonner[Verb] forgiveness pardon[Noun] forgives pardonne[Verb] forgiving indulgent[Adjective] forgo renoncer \a[Verb] forgoes renonce \a[Verb] forgotten oublie/[Adjective] forlorn de/laisse/[Adjective] formaldehyde formalde/hyde four quatre[Adverb] fox renard (m)[Noun] fractal fractale (f)[Noun] fractals fractales (f)[Noun] fraction fraction (f)[Noun] fractionate fractionner[Verb] fraternal fraternel[Adjective] fraternize fraterniser[Verb] friend ami[Noun] friendship Amitie[Noun] fringe frange[Noun] frog grenouille[Noun] frogs grenouilles[Noun] from de front devant[Preposition] fucked foutu[Adjective] fudge sucre a` la cre`me[Noun] fugue fugue[Noun] fulgurant fulgurant[Adjective] funk frouse[Noun] funniest le plus amusant[Adjective] funny amusant[Adjective] gab bavarde[Verb] gabardine gabardine[Noun] gabber comme\re[Noun] gabbing bavarder[Verb] gaberdine une gabardine[Noun] gadget un gadget[Noun] gaiety la gaieté[Noun] gaily gaiement[Adverb] gain le gain[Noun] gained gagne/[Verb] gaining gagnant[Verb] gala un gala[Noun] galactic galactique[Adjective] galaxies galaxies[Noun] galaxy une galaxie[Noun] gallant gallant[Adjective] gallantly gallamment[Adverb] gallantry la gallantrie[Noun] galleries galleries[Noun] gallery gallerie[Noun] gallon un gallon[Noun] gallop galloper[Verb] galloped gallope/[Verb] galloping gallopant[Verb] galvanic galvanique[Adjective] galvanism le galvanisme[Noun] galvanize galvaniser[Verb] galvanized galvanise/[Verb] game un jeu[Noun] games joues[Noun] garlic ail[Noun] gas essence[Noun] gasoline essence[Noun] ghostwriter négre[Noun] gift cadeau[Noun] gifts cadeaux[Noun] go aller[Verb] goal objectif[Noun] goals buts goat oie god dieu goddess de/esse goddesses de/esses godfather parrain[Noun] golf golf golfer geolfeur golfers golfeurs golfs golfs good bon;bien good bien goodbye au revoir goodnight bon nuit gopher gopher[Noun] gospel evangile[Noun] gown la robe grab saisir (an object)[Verb] gradient pente (math.)[Noun] gradually graduellement[Adverb] grammar grammaire (f)[Noun] grape le raisin[Noun] grapefruit le pamplemousse[Noun] habilitated habilite/[Verb] habilitation habilitation[Noun] habit coutume[Noun] habitant habitant[Noun] habitants habitants[Noun] habitat habitat[Noun] habitation demeure[Noun] habitual usuel[Adjective] had se faire avoir hand main[Noun] head tete heats series[Noun] heaven paradis[Noun] heavy lourd[Adjective] hectare hectare hectares hectares hectoliter hectolitre hedge haie hedgehog he/risson[Noun] heed suivre[Verb] heel talon heeler guerisseur heels talons height hauteur heir he/ritier held tenu[Adjective] helices helices[Noun] hell enfer[Noun] hello bonjour[Noun] helm barre[Noun] helmet casque[Noun] help aide[Noun] hemp chanvre[Noun] hen poule[Noun] herd troupeau[Noun] here ic,i[Noun] heron huron[Noun] hips flancs[Noun] hit frapper[Verb] hockey hockey[Noun] hogwash non sense[Noun] holidayer vacancier[Noun] holidays vacances home maison[Noun] homeless sans-abri[Noun] homes maisons[Noun] house maison[Noun] ice glace[Noun] instancing instanciation[Noun] internship stage professionnel en entreprise ou ailleurs jab planter[Verb] jabber baragouiner[Verb] jabberwocky (playing card) valet[Noun] jabberwocky Jaseroque, Bredoulocheux, Berdouilleux, Jabberwocheux[Noun] jack criq[Noun] jack valet[Noun] jackal chacal[Noun] jackals chacaux[Noun] jackass a^ne[Noun] jackdaw choucas (m)[Noun] jacket blouson[Noun] jacket veste[Noun] jackhammer marteau piqueur[Noun] jackknife canif[Noun] jackpot gros lot[Noun] jade jade[Noun] jaded brime/e(e)[Adjective] jag bombe, noce[Noun] jagged e'bre'che[Verb] jail emprisonner[Verb] jail prison jailbreak evasion[Noun] jailed emprisonne/[Adjective] jailer geo^lier[Noun] jailing incarce/ration[Noun] jailor geo^lier[Noun] jails prisons[Noun] jalopy guimbarde[Noun] jam confiture[Noun] jam enfoncer[Verb] jamb jambage[Noun] jammed coince/[Adjective] jammed enraye/[Adjective] jangle (bells) faire retenir[Verb] janitor agent d'entretien[Noun] janitor concierge[Noun] jar bocal[Noun] jar pot[Noun] jar secousse[Noun] jargon jargon (m)[Noun] jasmine jasmin[Noun] jaundice jaunisse[Noun] jaunt balade[Noun] jaunty désinvolte[Adjective] jaunty insouciant(e)[Adjective] javelin javelot[Noun] jaw ma^choir[Noun] jaws ma^choires[Noun] jay geai (m)[Noun] jazz jazz (m)[Noun] jazzy voyant(e)[Adjective] jealous jaloux, jalouse[Adjective] jealousy jalousie[Noun] jeer conspuer[Verb] jeer huer[Verb] jelly gele/e[Noun] jellyfish meduse[Noun] jeopardize compromettre[Verb] jeopardize mettre en danger[Verb] jerk abruti[Noun] jerk bousculer[Verb] jerry boche[Noun] jersey (cloth) jersey[Noun] jersey pull (m)[Noun] jest plaisanterie (f)[Noun] jester bouffon[Noun] jester fou[Noun] jet gicleur[Noun] jet re/acteur[Noun] jettison jeter, larguer[Verb] jetty jete/e[Noun] jewel joyau[Noun] jeweler bijoutier[Noun] jewelery bijouterie[Noun] jewelry bijouterie[Noun] jewels joyaux[Noun] jib (of crane) flèche (f)[Noun] jib (sail) foc (m)[Noun] jiffy (in a ~) en un clin d'oeil jig gigue (f)[Noun] jigsaw (puzzle) puzzle (m)[Noun] jihad lutte, combat (Islam)[Noun] jilt laisser tomber[Verb] jingle (bell) tinter[Verb] jingle (song) jingle (m), indicatif (m)[Noun] jingle (sound) cliquetis (m)[Noun] jinx poisse (f)[Noun] jitters trac[Noun] job boulot (colloq.)[Noun] job emploi (m)[Noun] job turbin (slang)[Noun] jobless au chômage[Adjective] jockey jockey (m)[Noun] jocular enjoué(e), jovial(e)[Adjective] jocund gai[Adjective] jodhpur jodhpur (m)[Noun] jog faire du jogging[Verb] jogging jogging (m)[Noun] join (re)joindre[Verb] join raccord (m)[Noun] joinable joignable[Adverb] joined (re)joint[Adjective] joiner menuisier (m)[Noun] joinery menuiserie (f)[Noun] joint (drugs) joint (m)[Noun] joint articulation[Noun] joint jointure[Noun] jointly conjointement[Adverb] joke blague (colloq.)[Noun] joke plaisanterie[Noun] joked plaisanta (pass.simp.,3rd sing[Verb] joker (playing card) joker (m)[Noun] jokingly en plaisantant[Adverb] jokingly pour rire[Adverb] jolly jovial(e), enjoué(e)[Adjective] jolt secousse[Noun] jolt soubresaut (m)[Noun] jonquils jonquilles[Noun] jostle bousculer[Verb] jot (~ down) noter[Verb] jot (of truth) grain(m), brin(m) journal (diary) journal (m)[Noun] journal (magazine) revue (f) journalism journalisme (m) journalist journaliste[Noun] journalists journalistes[Noun] journey periple[Noun] journey voyage[Noun] jovial jovial(e)[Adjective] jovially jovialement[Adverb] joy joie[Noun] joyful joyeux[Adjective] joyfully joyeusement[Adverb] joyless sans joie[Adverb] joyously joyeusement[Adverb] jubilant débordant(e) de joie[Adjective] jubilee jubilé (m)[Noun] judge juge[Noun] judge juger[Verb] judged juge/[Adjective] judgement jugement[Noun] judicial judiciaire[Adjective] judiciary magistrature (f)[Noun] judo judo (m)[Noun] jug broc[Noun] jug pichet[Noun] jug pot (m)[Noun] juggernaut poids (m) lourd[Noun] juggle jongler[Verb] juggler jongleur (m), jongleusse (f)[Noun] jugular jugulaire[Adjective] juice jus[Noun] juiceless sans jus juicier plus juteux juiciest le plus juteux juicy juteux, juteuse jukebox juke-box (m)[Noun] jumble mélange (m)[Noun] jumbo géant(e)[Adjective] jump sauter (inf.)[Verb] jumped sauta (pass.simp., 3rd sing.)[Verb] jumper robe (f) chasuble[Noun] jumpy nerveux(euse)[Adjective] junction (rail) embranchement (m)[Noun] junction jonction[Noun] jungle jungle (f)[Noun] junior junior juniper genie\vre[Noun] junk bric-à-brac (m)[Noun] junk camelotte (colloq.)[Noun] junk des ordures[Noun] junk du toc (colloq.)[Noun] junkers casseurs (colloq.)[Noun] junkers chiffonniers[Noun] junkie accro (colloq.)[Noun] junkie drogué(e)[Noun] junkyard une casse (automobile)[Noun] juridic juridique[Adjective] jurisdiction juridiction[Noun] jurist juriste[Noun] juror jure/[Noun] jurors jure/s[Noun] jury jury (m)[Noun] just juste justice justice (f)[Noun] justified justifie/(e)[Adjective] justify justifier[Verb] justly justement[Adverb] jut (~ out) avancer[Verb] juvenile puéril(e)[Adjective] juxtapose juxtaposer[Verb] kale chou[Noun] kaleidescope kale/idoscope[Noun] kaleidoscope kale/idoscope[Noun] kangaroo kangourou[Noun] karat carat (m)[Noun] karate karaté (m)[Noun] kayak kayak (m)[Noun] kebab brochette[Noun] keel la quille (naut.)[Noun] keep garder (inf.)[Verb] keeps toujours[Noun] keepsake souvenir (m)[Noun] keg caisson (liq.)[Noun] keg tonnelet (m), baril (m)[Noun] kennel niche (f)[Noun] kennel un chenil[Noun] kerchief un foulard[Noun] kernel amande (f)[Noun] kernel noyau[Noun] kernel trognon (fruit)[Noun] kerosene kérosène (m)[Noun] ketchup ketchup (m)[Noun] kettle une bouilloire[Noun] key (map) légende key une cle/, or clef[Noun] key une touche (keyboard)[Noun] keyboard un clavier[Noun] keyhole le trou de (la) serrure[Noun] keying taper (typewriter) (inf.)[Verb] keynote note (f) dominante[Noun] keypad (keyboard) pavé (m) numérique[Noun] keypad un clavier (adding machine)[Noun] khaki kaki[Adjective] kick (~ out) vider[Verb] kick donner (inf.) un coup de pied[Verb] kickback un retour de manivelle[Noun] kicked frappe/ du pied[Adjective] kicker qui donne des coups de pied[Noun] kickoff le depart synchronise/[Noun] kicks s'amuser kid un chevreau, une chevrette[Noun] kid un(e) gosse (colloq.)[Noun] kid un(e) mioche (colloq.)[Noun] kiddies les gamins[Noun] kiddies les gosses[Noun] kiddies les mioches (colloq.)[Noun] kidnap enlever (inf.)[Verb] kidnap kidnapper[Verb] kidnaped enleve/ (past.part.)[Adjective] kidnaper enlèvement (m)[Noun] kidnaper un ravisseur[Noun] kidnapers les|des ravisseurs[Noun] kidnaping un enle\vement[Noun] kidnapped enleve/[Verb] kidnapper un ravisseur[Noun] kidnappers les|des ravisseurs[Noun] kidnapping un enle\vement[Noun] kidnappings des enle\vements[Noun] kidney le rein[Noun] kidneys les|des reins[Noun] kidneys les rognons (cooking)[Noun] kids les|des gamins[Noun] kids les|des gosses[Noun] kill (fig.) mettre fin à[Verb] kill tuer[Verb] killer meurtrier (m),meutrière (f)[Noun] killer un tueur[Noun] killers des tueurs[Noun] killing meutre (m)[Noun] killing une tuerie[Noun] killings des tueries[Noun] killjoy rabat-joie (m)[Noun] kiln four (m)[Noun] kiln un fourneau[Noun] kilo kilo (m)[Noun] kilobytes kilo-octet (m)[Noun] kilogram kilogramme (abbr. kg)[Noun] kilohertz kilo-hertz (m)[Noun] kiloliter un kilolitre (abbr. kl)[Noun] kilometer un kilome\tre (abbr. km) kilowatt kilowatt (m)[Noun] kilt kilt (m)[Noun] kin aparente/ (a\...)[Adjective] kind aimable[Adjective] kind doux (de caracte\re)[Noun] kind gentil(le)[Adjective] kindergarten (le) jardin d'enfants[Noun] kindergarten (une) cre^che pour enfants[Noun] kindergarten (une) garderie (d'enfants)[Noun] kindergarten e/cole maternelle[Noun] kindhearted bon (de caracte\re, de coeur)[Noun] kindhearted tendre de coeur[Adjective] kindheartedness (la) tendresse de coeur[Noun] kindle (feeling) susciter[Verb] kindle (fire) allumer[Verb] kindlessly froidement[Adverb] kindlessly sans coeur[Adverb] kindliness (la) douceur[Noun] kindliness (la) gentillesse[Noun] kindly avec douceur[Adverb] kindly bienveillant(e)[Adverb] kindly doucement[Adverb] kindly gentiment[Adverb] kindness (la) douceur de coeur[Noun] kindness (la) gentillesse[Noun] kindred aparente/[Adjective] kindred semblable, similaire[Adjective] kinds des espe\ces[Noun] kinds des sortes (de...)[Noun] king (le) roi[Noun] kingdom (animals/plants) règne (m)[Noun] kingdom (le) royaume[Noun] kingdoms royaumes[Noun] kingfisher (un) martin pe^cheur (bird)[Noun] kingly royal[Adjective] kings (les) rois[Noun] kinky vicieux(ieuse)[Adjective] kiosk kiosque[Noun] kipper hereng (m) fumé[Noun] kiss baiser[Verb] kiss baiser[Noun] kiss bisou[Noun] kiss embrasser[Verb] kisses baisers[Noun] kisses bisous[Noun] kit (set) trousse (f)[Noun] kit (to be assembled) kit (m)[Noun] kitchen cuisine[Noun] kitchenette cuisinette[Noun] kitchens cuisines kitchenware (la) batterie de cuisine[Noun] kitchenware (les) ustensiles de cuisine[Noun] kite (un) cerf-volant[Noun] kith (~ and kin) parents et amis kiting jouer avec un cerf-volant[Verb] kitten chaton[Noun] kittens chatons[Noun] kitty (shared fund) cagnotte (f)[Noun] kiwi (bird) kiwi (m), aptéryx[Noun] kiwi (fruit) kiwi (m)[Noun] kleenex (un) mouchoir en papier[Noun] kleenex TM, (R), etc. papier-mouchoir[Noun] kleptomania (la) kleptomanie[Noun] kleptomaniac un(e) kleptomane[Noun] knack _ _ _ _ = avoir la main pour..[Noun] knack to have the _ = avoir le chic[Noun] knapsack (un) sac-a\-dos[Noun] knead pe/trir[Verb] kneadable pe/trissable[Adjective] kneader pe/trisseur[Noun] knee le genou[Noun] kneecap la rotule[Noun] kneel mettre à genoux[Verb] kneel s'agenouiller (inf.reflx.)[Verb] kneeling a\ genoux[Adverb] kneeling s'agenouillant[Verb] kneepad (un) prote\ge-genou[Noun] knelt s'agenouilla (pass.simp.)[Verb] knelt se mis(e) a\ genoux (pass.simp[Verb] knickers pantalon de golf (m)[Noun] knickknack (un) bibelot[Noun] knickknack (une) babiole[Noun] knife (un) canif[Noun] knife (un) couteau[Noun] knifes des couteaux[Noun] knifing une blessure au couteau[Noun] knight (chess) cavalier (m)[Noun] knight (un) chevalier[Noun] knighted e^tre sacre/ chevalier[Adjective] knighthood la chevalerie[Noun] knightly chevalier[Adjective] knights des chevaliers[Noun] knit (bones) se souder[Verb] knit froncer les sourcils[Verb] knit tricotter (inf.)[Verb] knitted tricotte/ (past.part.)[Adjective] knitting le tricot[Noun] knitwear le tricot[Noun] knives des couteaux[Noun] knob (la) poigne/e[Noun] knob (un) bouton (de commande)[Noun] knobby noueux, noueuse[Adjective] knobs (les) boutons (de commande)[Noun] knock frapper (inf.)[Verb] knock tapoter[Verb] knockdown démolir[Verb] knockout knock-out (m)[Noun] knot (un) noeud[Noun] knots des noeuds[Noun] knotted noue/ (past.part.)[Adjective] knotty épineux(euse)[Adjective] knotty noueux[Adjective] know savoir (inf.)[Verb] knower celui|celle qui a le savoir[Noun] knowhow le savoir-faire[Noun] knowhow technique (f)[Noun] knowing entendu(e)[Adjective] knowingly en connaissance de cause[Adverb] knowingly sciemment[Adverb] knowledge la connaissance[Noun] knowledge le savoir[Noun] knowledgeable bien informé(e)[Adjective] known connu (past.part.)[Verb] knows (il|elle) sait[Verb] knuckle (meat) jarret (m) knuckle (une) phalange[Noun] knucklebone (une) phalange[Noun] knuckles (un) poing ame/ricain[Noun] knuckles les phalanges[Noun] koala koala (m)[Noun] kosher cache\re[Adjective] kosher kasher[Adjective] kraut (la) choucroute[Noun] kraut (un) boche (slang)[Noun] krauts les chleus (slang.)[Noun] kudzu lierre du Japon[Noun] lab labo[Noun] labor travail (m)[Noun] laborer l'ouevrier[Noun] laborer l'ouvrier[Noun] laborers les ouevriers[Noun] laborers les ouvriers[Noun] laborious laborieux (m), laborieuse (f)[Noun] labyrinth labyrinthe (m)[Noun] lace dentelle (f)[Noun] laceration lace/ration (f)[Noun] lacerations lace/rations (f)[Noun] lack manque[Noun] lackadaisical nonchalant[Adjective] lackey laquais[Noun] lacking simplet[Adjective] lackluster terne[Adjective] laconic laconique[Adjective] laconically laconiquement[Adjective] lacquer (for wood) vernis (m)[Noun] lacquer laque[Noun] lad garcon[Noun] ladies Mesdames[Noun] lady dame[Noun] ladybird coccinelle[Noun] ladybug coccinelle[Noun] lake lac[Noun] lakes lacs[Noun] lamb veau[Noun] lambs veaux[Noun] laminated laminé[Verb] laminates lamine[Verb] lamp lampe[Noun] language langue[Noun] laugh rire[Verb] leather cuir[Noun] leave laisser[Verb] lectern lutrin[Noun] lecture confe/rence[Noun] lecturer confe/rencier[Noun] ledge rebord[Noun] ledger registre[Noun] lee co^te/[Noun] leg jambe[Noun] legal legal[Adjective] legality legalite[Noun] legalize legaliser[Noun] legally legalement[Adverb] legate leguer[Verb] legation legation[Noun] legend legende[Noun] legendary lengendaire[Adjective] legion legion[Verb] letter additive[] letter ethnic[] letter neighbor[] like aimer[Verb] live vivre[Verb] love aime love amour[Noun] lover amant[Noun] luck chance[Noun] lunch le de/jeuner[Noun] ma maman[Noun] ma Mère[Noun] ma'am M'dame[Noun] ma'am madame[Noun] ma'am mademoiselle[Noun] macabre lugubre[Adjective] macabre macabre[Adjective] macabrely macabrement[Adverb] macadam bitume[Noun] macadam macadam[Noun] macadamize goudronner[Verb] macadamize macadamiser[Verb] macadamized goudronné[Verb] macadamized macadamise/[Adjective] macadamizes goudronnes[Verb] macadamizes macadamise[Verb] macadamizing goudronnant[Verb] macaque macaque[Noun] macaque macaque[Noun] macaroni macaroni[Noun] macaronies macaronis[Noun] macaroon macaron[Noun] macaw l'ara[Noun] mace sceptre[Noun] macerate mace'rer[Verb] macerate maçérer[Verb] macerated macere'[Adjective] maceration mace'ration[Noun] macerations mace'rations[Noun] maces masse[Noun] machete machette[Noun] machination machination[Noun] machine machine[Noun] machined machine/[Adjective] machineries machinerie machinery machinerie[Noun] machines machines[Noun] machinist machiniste[Noun] machinists machinistes[Noun] machismo machisme[Noun] macho macho[Adjective] macrocephalic macroce'phale[Adjective] macrocosm macrocosme[Noun] macroeconomics macroeconomie[Noun] macroevolution macroe'volution[Noun] macroevolutionary macroe'volutionnaire[Adjective] macroinstruction macroinstruction macromolecular macromole'culaire[Adjective] macromolecule macromole'cule[Noun] macromolecules macromole'cules[Noun] macropathological macropathologique[Adjective] macropathology macropathologie[Noun] macrophage macrophage[Noun] macrophages macrophages[Noun] macrophagic macrophage[Adjective] macroprocessor macroprocesseur[Noun] macroscopic macroscopic[Adjective] macrosimulation macrosimulation[Noun] macrostructure macrostructure[Noun] maculate maculer[Verb] maculated macule'[Adjective] maculates macule[Verb] maculation maculation[Noun] maculations maculations[Noun] mad fache'[Adjective] mad fou, folle[Adjective] madam madame[Noun] madams mesdames[Noun] maddened rendu fou[Adjective] made a fait[Verb] made j'adore[Verb] mademoiselle mademoiselle[Noun] mademoiselles mesdemoiselles[Noun] maestro maestro[Noun] mafioso mafieux[Noun] magazine magazine[Noun] magic magique[Adjective] magician magicien[Noun] magicians magiciens[Noun] magistral magistral[Adjective] magistrally magistralement[Adverb] magistrature magistrature[Noun] magma magma[Noun] me moi[Pronoun] mead le hydromel[Noun] meadow le pre/[Noun] meadow pre/[Noun] meadowland les prairies[Noun] meadows pre/s[Noun] meager maigre[Adjective] meagerly maigrement[Adverb] meagre maigre[Adjective] meal repas[Noun] meals repas[Noun] mealtime heure du repas[Noun] mean moyenne[Noun] meander me/andre[Noun] meaningless insense/[Adjective] meanings significations[Noun] means moyen[Noun] meanwhile entretemps[Adverb] measurable mesurable[Adjective] meat viande[Noun] meatball boulette de viande[Noun] meatballs boulettes de viande[Noun] mechanical me/canique[Adjective] mechanician me/canicien[Noun] mechanism me/canisme[Noun] mechanisms me/canismes[Noun] medal me/daille[Noun] medallion me/daillon[Noun] medallions me/daillons[Noun] mediatrice me/diatrice[Noun] mediatrix me/diatrice[Noun] medic me/decin[Noun] medical me/dical[Adjective] medically me/dicalement[Conjunction] medicament me/dicament[Noun] medicaments me/dicaments[Noun] medicinal me/dicinal[Adjective] medicine me/decine[Noun] medicines me/decines[Noun] medico medico[Adjective] medicolegal me/dicole/gal[Adjective] medics me/decins[Noun] medieval me/die/val[Adjective] medievalist me/die/valiste[Noun] medievalists me/die/valistes[Noun] mediocre me/diocre[Adjective] mediocrities me/diocrite/s[Noun] mediocrity me/diocrite/[Noun] meditate me/diter[Verb] meditates me/dite[Verb] meditation me/ditation[Noun] meditations me/ditations[Noun] meditative me/ditatif[Adjective] meditatively d'un air me/ditatif[Adjective] medium me/dium[Noun] medlar ne\fle[Noun] medley me/lange[Noun] medleys me/langes[Noun] medulla me/dulle[Noun] medusae me/duses[Noun] meek doux[Adjective] meekly avec soumission[Adjective] meekness soumission[Noun] meerschaum pipe en e/cume de mer[Noun] megabyte me/ga-octet[Noun] megabytes me/ga-octets[Noun] megacycle me/gacycle[Noun] megahertz me/gahertz[Noun] megalith me/galithe[Noun] megalithic me/galitic[Adjective] megalomania me/galomanie[Noun] megalomaniac me/galomane[Noun] megalomaniacal me/galomane[Adjective] megaphone me/gaphone[Noun] melancholia me/lancolie[Noun] melancholic me/lancolique[Adjective] melange me/lange[Noun] melodic me/lodique[Adjective] melodies me/lodies[Noun] melodious me/lodieux[Adjective] melodrama me/lodrame[Noun] melodramas me/lodrames[Noun] melodramatic me/lodramatique[Adjective] melody me/lodie[Noun] melon melon[Noun] melons melons[Noun] melted fondu[Pronoun] member membre[Noun] members membres[Noun] membrane membrane[Noun] membranes membranes[Noun] membranous membraneux[Adjective] memoir me/moire[Noun] memoirs me/moires[Noun] memorable me/morable[Adjective] memories souvenirs[Noun] memorize me/moriser[Verb] memorized me/morise/[Pronoun] memory me/moire, souvenir[Noun] men hommes[Noun] menace menace[Noun] menaced menace/[Adjective] menagerie me/nagerie[Noun] menageries me/nageries[Noun] menhir menhir[Noun] meningitis me/ningite[Noun] meniscus me/nisque[Noun] menopause me/nopause[Noun] menstrual menstruel[Adjective] menstruation menstruation[Noun] menstruations menstruations[Noun] mental mental[Adjective] mentality mentalite/[Noun] menthol menthol[Noun] mention mentionner[Verb] menu menu[Noun] meow miauler[Verb] meowing miauleur[Adjective] meows miaule[Verb] mephitic me/phitique[Adjective] mercantile mercantile[Adjective] mercantilism mercantilisme[Noun] mercenaries mercenaires[Noun] mercenary mercenaire[Noun] merchant marchand[Noun] merchants marchands[Noun] mercury mercure[Noun] mercy pitie/[Noun] meridian me/ridien[Noun] meridians me/ridiens[Noun] meridional me/ridional[Adjective] merino me/rino[Noun] merit me/rite[Noun] meritocracy me/ritocratie[Noun] merits me/rites[Noun] mermaid sire\ne[Noun] mermaids sire\nes[Noun] merry joyeux[Adjective] message message[Noun] messages messages[Noun] messiahs messie[Noun] messianic messianique[Adjective] moan gémir[Verb] moaned gémit[Verb] moaning gémissant[Verb] moans gémissements moat fossé[Noun] moats fosséa[Noun] mob foule[Noun] mock ridiculiser[Verb] mocked ridiculisé[Verb] mockery moquerie[Noun] modal modal[Adjective] moon lune[Noun] moonlight clair de lune moons lunes moose orignal naive naif, naive[Adjective] naively naivement[Adverb] naked nu[Noun] name prenom(persons), nom (things)[Noun] named nomme[Adjective] nameless sans nom[Adjective] namely nomement [Adverb] namely nommement[Adverb] names prenoms, noms (see name)[Noun] national national/e[Adjective] nationalism nationalisme[Noun] nationalist nationaliste[Adjective] native habitant/e du pays[Noun] natural naturel (le)[Adjective] naturalize naturaliser[Verb] naturally naturellement[Adverb] neap mortes-eaux[Noun] near proche[Adjective] nearby près[Adverb] nearer plus proche[Adjective] neglect abandonner[Verb] neighbor voisin[Noun] neighbors voisins[Noun] network réseau networked réseauté networks réseaux nine neuf[Adjective] nineteen dix-neuf[Adverb] nineteenth dix-neuvie\me[Adjective] nineties les anne/es quatre-vingt-dix[Noun] ninetieth quatre-vingt-dixie\me[Adjective] ninety quatre-vingt-dix[Adverb] ninetyfold quatre-vingt-dix fois[Adverb] ninth neuvie\me[Adjective] niobium niobium (m)[Noun] nip te/ton (m)[Noun] nipple te/ton[Noun] nipples te/tons[Noun] nips te/tons (m)[Noun] nirvana nirvana[Noun] nitrate nitrate[Noun] nitrated nitrate/[Noun] nitrates nitrates[Noun] nitrating nitratant[Adverb] nitration nitratation[Noun] nitrations nitratations[Noun] nitric nitrique[Adjective] nitride nitrate (m)[Noun] nitrogen azote[Noun] nitroglycerin nitroglyce/rine[Noun] nitroglycerine nitroglyce/rine[Noun] noble noble[Noun] nobleman noble[Noun] noblemen nobles[Noun] nobleness noblesse[Noun] nobody personne[Pronoun] noctambulism noctambulisme[Noun] noctambulist noctambule[Noun] nocturn noctune nocturnally de nuit[Noun] now maintenant[Adverb] nowadays de nos jours, aujourd'hui[Adverb] noway pas question, pas du tout[Adverb] noway pas question, pas du tout[Adverb] oaf nigaud[Noun] oafish stupide[Adjective] oafishness sottise[Noun] oak che^ne[Noun] oar rame[Noun] oarsman rameur[Noun] oasis oasis[Noun] oat avoine[Noun] oath serment[Noun] oatmeal farine d'avoine[Noun] obdurate inve/te/re/[Adjective] obedience obe/issance[Noun] obedient soumis[Adjective] obelisk obe/lisque[Noun] obese obe\se[Adjective] obesity obe/site/[Noun] ocean ocean[Noun] one un[Noun] orange orange[Noun] oranges oranges[Noun] orbit orbite[Noun] orbital orbital[Adjective] orbits orbites[Noun] orchestra orchestre[Noun] orchestral orchestral[Adjective] orchestras orchestres[Noun] orchestrated orchestré[Adjective] order commande[Noun] ordered ordonné[Adjective] organism organisme[Noun] organisms organismes[Noun] organist organiste[Noun] organists organistes[Noun] organization organisation[Noun] organizations organisations[Noun] organize organiser[Verb] organized organisé[Adjective] organs organes[Noun] orgasm orgasme[Noun] orgasms orgasmes[Noun] orgies orgies[Noun] orgy orgie[Noun] orient orient[Noun] orientable orientable[Adjective] oriental oriental[Adjective] orientation orientation[Noun] orientations orientations[Noun] oriented orienté[Adjective] orients orients[Noun] orifice orifice[Noun] orifices orifices[Noun] orificial orifique[Adjective] origin origine[Noun] original original[Adjective] originality originalité[Adjective] originally originalement[Adverb] originals originaux[Adjective] origins origines[Noun] ornamental ornemental[Adjective] ornithology ornithologie[Noun] orthodox orthodoxe[Adjective] orthodoxes orthodoxes[Adjective] orthogonal orthogonal[Adjective] pace rhytme[Noun] pace vitesse[Noun] pacemaker stimulateur cardiaque (m), pacemaker (m)[Noun] pachyderm pachyde\rme[Noun] pacific pacifique[Noun] pacifically pacifiquement[Adverb] pacification pacification(f)[Noun] pacifications pacificateur / -trice [Noun] pacificist pacifiste[Noun] pacifier tétine (f), sucette (f) pacifism pacifisme[Noun] pacifist pacifiste[Noun] pacify apaiser[Verb] pacify pacifier[Verb] package 2)paquet(m);3)ballot(m)[Noun] package emballage[Noun] packaged emballeE[Adverb] packaged paquet (m)[Noun] packed (~ with) bourré(e) de packet 1) paquet (m) ;2)ballot(m)[Noun] packing emballage (m)[Noun] pact pacte, contrat[Noun] pacts pcates, contrats[Noun] pad coussinet, tampon[Noun] padding rembourrage, remplissage[Noun] paddle pagaie, palette[Noun] paddock enclos, paddock[Noun] padlock cadenas[Noun] padlock cadenasser[Verb] padrone patron /nne[Noun] paella paella[Noun] pagan pai.en/i.enne) pagan payen /nne[Noun] pagans païen(ne)s[Noun] pageant spectacle[Noun] pageantry apparat[Noun] paid payé(e)[Adjective] pail seau[Noun] pain douleur[Noun] pained peiné(e)[Adjective] painful douleureux[Adjective] painful pénible[Adjective] painfully douloureusement[Adverb] painstaking assidu(e)[Adjective] paint peindre[Verb] paint peinture[Noun] paintbrush pinceau[Noun] painter peintre[Noun] painters peintre[Noun] painting peinture[Noun] paints couleurs[Noun] pair couple[Noun] pajamas pyjama[Noun] pal copain (m)[Noun] pal copine (f) palace palais[Noun] palatable agréable au goût[Adjective] palaver palabres (f)[Noun] pale pâle[Adjective] palette palette (f)[Noun] pall voile (m)[Noun] pallet palette (f)[Noun] pallette palette (f)[Noun] pallor pâleur (f)[Noun] palm (~ tree) palmier (m)[Noun] palm paume (f)[Noun] palpable évident(e)[Adjective] palpable manifeste [Adjective] paltry dérisoire[Adjective] pamper choyer, dorloter[Verb] pamphlet brochure (f)[Noun] pan casserole (f)[Noun] panacea panacée (f)[Noun] panama Panama (m)[Noun] pancake crêpe (f)[Noun] panda panda (m)[Noun] pandemonium tohu-bohu (m)[Noun] pane vitre (f), carreau (m)[Noun] panel invités (m)[Noun] paneling lambris (m)[Noun] panelling lambris (m)[Noun] pang tiraillement (m)[Noun] panic panique (f)[Noun] panic paniquer[Verb] panicky paniqué(e)[Adjective] panorama panorama (m)[Noun] pansy pensée(f)[Noun] pant haleter[Verb] panther panthère (f)[Noun] panties culotte (f)[Noun] pantry garde-manger (m)[Noun] pants pantalon (m)[Noun] papa papa (m)[Noun] paper papier (m)[Noun] paperback livre de poche (m)[Noun] parameter paramètre[Noun] passer passeur[Noun] passion passion[Noun] passionately passionne/ment[Adverb] passive passif[Adjective] passivity passivite/[Noun] password mot de passe[Noun] passwords mots de passe[Noun] past passe/[Noun] pasta pâtes alimentaires[Noun] peat tourbe[Noun] pectorals pectoraux[Noun] peculiar important penitence pe/nitence[Noun] penitences pe/nitences[Noun] penitency pe/nitence[Noun] penitent pe/nitent[Noun] pentadactyl pentadactyle[Adjective] pentadactylism pentadactylisme[Noun] pi pi[Noun] pianist pianiste[Noun] pianistic pianistique[Adjective] piano piano[Noun] picture image[Noun] pictures images[Noun] pie tarte[Noun] pies tartes[Noun] pig cochon[Noun] pigeonhole pigeonnier[Noun] pigment pigment[Noun] pigmentation pigmentation[Noun] pigments pigments[Noun] pigs cochons[Noun] pilot pilote[Noun] pilots pilotes[Noun] pilule pilule[Noun] pine pin[Noun] pineapple ananas[Noun] pineapples ananas[Noun] pines pins[Noun] pink rose[Noun] pocket poche[Noun] pocketbook livre de poche[Noun] pocketbooks livres de poche[Noun] pockets poches[Noun] podium podium[Noun] pogrom pogrom[Noun] pogroms pogroms[Noun] pointer pointeur[Noun] pointers pointeurs[Noun] pointillism pointillisme[Noun] pointillist pointilliste[Noun] pointilliste pointilliste[Noun] pointillistic pointilliste[Noun] poison poison[Noun] poisonous poison[Adjective] poisonousness toxicite/[Noun] poisons poisons[Noun] polar polaire[Adjective] polarities polarite/s[Noun] polarity polarity[Noun] polarize polariser[Verb] polarized polarise/[Adjective] polemical pole/mique[Adjective] polemically de fac,on pole/mique[Adjective] polemically de manie\re pole/mique[Adverb] polemicize pole/miquer police police[Noun] policeman agent de police[Noun] policeman agent[Noun] policeman policier[Noun] policemen agents de police[Noun] policemen agents[Noun] policemen policiers[Noun] policewoman contractuelle[Noun] policewomen contractuelles[Noun] policy politique[Noun] polish polonais[Adjective] polish Polonais[Noun] polite poli[Adjective] politely poliment[Adverb] politeness politesse[Noun] political politique[Adjective] politically politiquement[Adverb] politician politicien[Noun] politicians politiciens[Noun] politics politique[Noun] polka polka[Noun] pollutant polluant[Noun] pollute polluer[Verb] polluted pollue/[Adjective] polluter pollueur[Noun] pollution pollution[Noun] polonium polonium[Noun] poltergeist poltergeist[Noun] polyandrous polyandre[Adjective] polyandry polyandrie[Noun] pour french[Noun] pout moue[Noun] poverty pauvrete/[Noun] powder poudre[Noun] powdery poudreux[Adjective] power puissance[Noun] powerful puissant[Adjective] powerless impuissant[Adjective] powwow assemble/e[Noun] practicability possibilite/[Noun] practicable re/alisable[Adjective] practical pratique[Adjective] pray prier[Verb] prayer prie\re[Noun] prayers prie\res[Noun] praying en prie\res[Adjective] praying prie\re[Noun] preach pre^cher[Verb] preach prononcer[Verb] preacher pasteur[Noun] preacher pre/dicateur[Noun] preachers pasteurs[Noun] preachers pre/dicateurs[Noun] preaches pre^che[Verb] preaches prononce[Verb] preachify faire la morale[Verb] preaching pre/dication[Noun] preaching pre^cheur[Adjective] preaching sermons[Noun] preachy pre^cheur[Adjective] preachy sermonneur[Adjective] preamplifier pre/amplificateur[Noun] preamplifiers pre/amplificateurs[Noun] prearrange arranger au pre/alable[Verb] prearrange arranger d'avance[Verb] prince prince[Noun] princedom principaute/ princely princier[Adjective] princes princes[Verb] princess princesse[Noun] principal principal[Noun] principal directeur[Noun] principalities principaute/s[Noun] principality principaute/ principally principalement principally surtout principals directeurs principle principe[Noun] principles principes print empreinte[Noun] print impression[Noun] print marque printable imprimable[Adjective] printed imprime/[Adjective] printer imprimeur[Noun] printer imprimante[Noun] priorities priorite/ priorities priorite/s priority priorite/ prove prouver[Verb] pulse impulsion[Noun] pulverizable pulverisable[Adjective] pulverizables pulverisables[Adjective] pulverization pulverisation[Noun] pulverize pulveriser[Verb] pulverized pulvérisé[Verb] pulverizer pulverisateur[Noun] pulverizers pulvérisateurs[Noun] pulverizes pulvérises[Verb] pulverizing pulve/risant[Verb] puma puma[Noun] pump pomper[Verb] push pousser[Verb] pushchair chaise roulante[Noun] pushing poussé[Verb] put mettre[Verb] putdown poser[Verb] putout éteindre[Verb] putrefaction putréfaction[Noun] quail caille[Noun] quails cailles[Noun] quake trembler[Verb] quality qualite/[Noun] qualm scrupule[Noun] qualms scrupules[Noun] quantity quantite/ quarrel se disputer[Verb] quarry carri\ere[Noun] quarter quartier[Noun] quarterdeck plage arri\ere[Noun] quarterfinal quart de finale[Noun] queen reine[Noun] queer bizarre[Adjective] quell re/primer[Verb] quench se de/salte/rer querulous ronchonneur[Adjective] query question[Noun] quest que^te[Noun] question question[Noun] queue queue[Noun] quibble chicaner[Verb] quick rapide[Adjective] quicklime chaux vive[Noun] quickly rapidement[Adverb] quicksand sables mouvants[Noun] quicksilver vif-argent[Noun] quiet tranquille[Adjective] quieten calmer[Verb] quietly doucement[Adverb] quill plume d'oie[Noun] quilt e/dredon[Noun] quirk bizarrerie[Noun] quit se rendre[Verb] quite assez[Adjective] quota quota[Noun] quotation citation[Noun] quote citer[Verb] r r[Noun] rabbet feuillure[Noun] rabbi rabbin rabbinic rabbinique[Adjective] rabbit lapin[Noun] rabbits lapins[Noun] rabble cohue[Noun] rabid enrage/[Adjective] rabies rage raccoon raton-laveur race course[Noun] racehorse cheval de course racemic rece/mique[Adjective] racer coureur races courses[Noun] rachis rachis[Noun] rachitic rachitique[Adjective] rachitis rachitisme[Noun] racial racial[Adjective] racialism racisme[Noun] racialist raciste[Noun] racialistic raciste[Adjective] racing de course racism racisme[Noun] racist raciste[Noun] rack e/tag\ere[Noun] racket raquette[Noun] racket tumulte[Noun] radar radar[Noun] radars radars[Noun] radio radio[Noun] read lire[Verb] readability lisibilite/[Noun] readable lisible[Adjective] reader lecteur[Noun] readers lecteurs[Noun] readership lecteurs[Noun] readership lectorat[Noun] readily de bonne gra^ce[Adverb] readily facilement[Adverb] readily volontiers[Adverb] readiness empressement[Noun] readiness facilite/[Noun] reading interpre/tation[Noun] reading lecture[Noun] reading releve/[Noun] readings interpre/tations[Noun] readings lectures[Noun] readjust rajuster[Verb] readjust re/ajuster[Verb] readjusts rajuste[Verb] readjusts re/ajuste[Verb] readout affichage[Noun] readout d'affichage[Adjective] readouts affichages[Noun] reads lit[Verb] ready dispose/[Adjective] ready pre^t[Adjective] ready prompt[Adjective] reaffirm affirmer de nouveau[Verb] reaffirm re/affirmer[Verb] reaffirms affirme de nouveau[Verb] reaffirms re/affirme[Verb] reagent re/actif[Noun] real naturel[Adjective] real ve/ritable[Adjective] real vrai[Adjective] realisable re/alisable[Adjective] realism re/alisme[Noun] realist re/aliste[Noun] realistic plein de re/alisme[Adjective] realistic re/aliste[Adjective] realistically avec re/alisme[Adverb] reality re/alite/[Noun] realize re/aliser[Verb] really vraiment[Adverb] reporter le reporter[Noun] represent repre/senter[Verb] request demande[Noun] request exiger[Verb] request reque^te[Noun] road rue[Noun] roads rues roadwork chantier[Noun] robber voleur[Noun] room chambre rotting decay[Verb] sabbat un sabbat[Noun] sabbath sabbat[Noun] sabbatic sabatique[Noun] sabbatical sabbatique[Adjective] saber sabre[Noun] sabin nom de personne qui a decouvert le vaccine contre poliomyltie[Noun] sable martre[Noun] sabot sabot[Noun] sabotage sabotage[Noun] sabotaged saboté[Verb] sabotages sabotages[Noun] saboteur saboteur[Noun] sabra citoyen du pays Israel, personne ne en Israel[Noun] sabras citoyens du pays Israel, personnese nes en Israel[Noun] saccade une saccade[Noun] saccharin saccharine[Verb] saccharine saccharin[Noun] saccharose saccharose[Noun] sacerdotal appartient a une chose religieuse[Adjective] sacerdotally une acte faite en manière sacrée[Adverb] sachet un sachet[Noun] sack sac[Noun] sack virer[Verb] sackcloth une vêtement de deuil[Noun] sacked vire/[Adjective] sackful une mesure "plein d'un sac"[Adjective] sacks piller[Verb] sacrament sacrament[Noun] sacramental sacremental[Adjective] sacraments sacrements[Noun] sacre sacre[Noun] sacred sacre/[Adjective] sacrifice sacrifice[Noun] sacrificed sacrifier[Verb] sacrifices sacrifices[Noun] sacrilege sacrile\ge[Noun] sad malheureux[Adjective] sad triste[Adjective] sadden attrister[Verb] sadder plus triste[Adjective] saddest plus triste[Adjective] saddle selle[Noun] saddlebag une sacoche[Noun] saddlebags des sacoches saddlebow un arçon saddlecloth une housse ( de cheval)[Noun] saddled sellé[Verb] saddleless sans selle saddler un sellier[Noun] saddlery une sellerie[Noun] saddles une selle saddletree un bois de selle[Noun] saddling sellant[Verb] sadism sadisme[Noun] sadist sadiste[Noun] sadistic sadique[Adjective] sadistically sadiquement[Adverb] sadists sadistes[Noun] sadly tristement[Adverb] sadness tristesse[Noun] safari un voyage, en particulier en Afrique[Noun] safe coffre-fort[Noun] safecracker une personne qui ouvre une caisse illégalement[Noun] safecracking l'acte d'ouvrir une caise illégalement[Noun] safeguard une sauvegarde[Noun] safeguarded sauvegardé[Verb] safeguards garde fous[Noun] safer pplus sauf[Adjective] safes les caisses[Noun] safest le plus sauf[Adjective] safety le sûreté[Noun] safflower le carthame[Noun] saffron le safran[Noun] sag plier, ployer[Verb] saga une saga[Noun] sagacious prudent[Adjective] sagaciously prudemment[Adverb] sagaciousness la sagacité[Noun] sagacity la sagacité[Noun] sage le sage[Noun] sagely sagement[Adjective] sago le sagou[Noun] saguaro une type de cactus[Noun] sahib une forme d'addresser pour un homme des Indes[Noun] said dit[Verb] sail naviguer[Verb] sail voile[Noun] sailable navigable[Adjective] sailboat un bateau à voiles[Noun] sailboater un marin des bateua à voiles[Noun] sailcloth la toile à voiles[Noun] sailor marin[Noun] sailors les marins[Noun] sails les voiles[Noun] sainfoin le sainfoin ( bot.)[Noun] saint saint(e)[Noun] sainted sacré[Adjective] sainthood la sainteté[Noun] saints saint(e)s[Noun] saith dit ( vieux anglais)[Verb] sake le vin du riz japonais[Noun] salability vendabilite/[Adjective] salacious grivois[Adjective] salad salade[Noun] salads salades[Noun] salamander salamandre[Noun] salami salami[Noun] salaried salarie/[Adjective] salaries salaires[Noun] sale solde[Noun] saleable vendable[Adjective] saleroom la salle des ventes[Noun] sales les ventes[Noun] salesclerk un vendeur salesgirl une vendeuse[Noun] saleslady une vendeuse[Noun] salesman un vendeur[Noun] salesmanship l'art de vendre[Noun] salesmen les vendeurs[Noun] salespeople les vendeurs[Noun] salesperson un vendeur[Noun] salesroom les salles de ventes[Noun] saleswoman une vendeuse saleswomen les vendeuses[Noun] salient saillant[Adjective] saline salin[Adjective] salinity la salinité[Noun] salinometer un salinomère[Noun] salinometers des salinomètres[Noun] saliva salive[Noun] salivary salivaire[Adjective] salivate saliver[Verb] salivated a fait saliver[Verb] salivates fait saliver[Verb] salivating faisant saliver[Verb] salivation ;a salivation[Noun] sallies les sorties[Noun] sallow jaunâtre[Adjective] sallowish un peu jaunâtre[Adjective] salmon saumon[Noun] salmons saumons[Noun] salon salon[Noun] salons salons[Noun] salt sel[Noun] saltwater l'eau de mer[Noun] saltworks la saline[Noun] saltwort le soude ( bot.)[Noun] salty sale/[Adjective] salubrious salubre[Adjective] salubrity la salubrité[Noun] salvage le sauvetage[Noun] salver le plateau[Noun] samba la Samba, une danse originée du Brasil[Noun] same même[Adjective] sampan un bateua chinois[Noun] samphire le passe-pierre (bot.)[Noun] samurai un guerrier ancien japonais[Noun] samurais des guerriers anciens japonais[Noun] sand le sable[Noun] sandal la sandale[Noun] school e/cole[Noun] sea mer[Noun] sell vendre[Verb] seller le vendeur[Noun] sellers les vendeurs[Noun] serendipity le serendiptiy[Verb] serene le serene seven sept[Adverb] sevenfold sept fois[Adverb] seventeen dix-sept[Adverb] seventeenth dix-septie\me[Adjective] seventh septie\me[Adjective] seventies les anne/es soixante-dix[Noun] seventieth soixante-dixie\me[Adjective] seventy soixante-dix[Adverb] seventyfold soixante-dix fois[Adverb] sever blesser[Verb] severalfold plusieurs fois[Adverb] severe grave[Adjective] severed blesse/ (m), blesse/e (f)[Adjective] severely gravement[Adverb] severities blessures (f)[Noun] severity gravite/ (f)[Noun] sewage e/pandage (m)[Noun] sex sexe (m)[Noun] sexagenarian se/xage/naire[Adjective] shades lunettes de soleil (f)[Noun] shadow ombre (f)[Noun] shadows ombres[Noun] shagreen chagrin[Noun] shah schah[Noun] shake secouer[Verb] shakedown lit de fortune[Noun] shaken secoue/[Adjective] shaky tremblant[Adjective] shaman chaman[Noun] shamanism chamanisme[Noun] shampoo shampooing shampoos shampooings sheep agnis[Noun] sheepherder pastor[Noun] ship ba^teau ship navire[Noun] shit merde[Noun] sick malade[Adverb] silver argent[Adjective] sing chanter[Verb] singer chanteur[Noun] sink couler[Verb] six six[Adverb] sixteen seize[Adverb] sixteenth seizie\me[Adjective] sixties les anne/es soixante (f)[Noun] sixty soixante[Adverb] sixtyfold soixante fois[Adverb] size taille (f), dimension (f)[Noun] skate patin (m)[Noun] skateboard planche a\ roulettes (f)[Noun] skateboarder planchiste (m)[Noun] skateboarding faire de la planche a\ roulettes[Verb] skateboards planches a\ roulettes (f)[Noun] skater patineur (m), patineuse (f)[Noun] skaters patineurs (m), patineuses (f)[Noun] skates patins (m)[Noun] skating patinage (m)[Noun] skill Habilete/[Noun] skilled habile[Adjective] skilless maladroit[Adjective] skillful adroit[Adjective] skills talents[Noun] sky ciel[Noun] skylark rossignol[Noun] skyscraper gratte-ciel[Noun] snout groin[Noun] snow neige[Noun] snowball boule de neige[Noun] snowflake flocon de neige snowman bonhomme de neige[Noun] snowstorm tempe^te de neige[Noun] software logiciel[Noun] sorrel oseille[Noun] sorrily tristement[Adverb] sorrow tristesse[Noun] sort trier[Verb] sorted trié[Adjective] sorter trieur[Noun] soul âme[Noun] spectra pl de spectrum, spectre[Noun] spectrum Phys: spectre; Fig: gamme (de produit)[Noun] speculate s'interroger, speculer, conjecturer[Verb] speculation meditation; conjectures ; speculation staple agrafe[Noun] stapled agraf/e[Adjective] stapler agrafeuse[Noun] staplers agrafeuses[Noun] staples agrafes[Noun] star e/toile[Noun] stars e/toiles[Noun] start de/part[Noun] stifled e/touffe/ strength force[Noun] stupid Stupide[Adjective] subject asignatura[Noun] succeed re/ussir[Verb] success re/ussite/[Noun] sun soleil[Noun] sunbathe se bronzer[Verb] sunny ensoleille/[Adjective] suppressed e/touffe/ suspect soupc,onner[Verb] swear jurer ; preter serment[Verb] tab happy[Adjective] tab sortir[Verb] tabernacle tabernacle[Noun] table table[Noun] tableau tableau[Noun] tableaus tableaux[Noun] tableaux tableaux[Noun] tablecloth nappe[Noun] tablecloths nappes[Noun] tables tables[Noun] tablet comprime/[Noun] tablets comprime/s[Noun] taboo tabou[Noun] taboos tabous[Noun] tachometer tachyme\tre[Noun] tachometers tachyme\tres[Noun] tacit tacite[Adjective] tail queue (of animal)[Noun] tailor tailleur[Noun] tailored fait sur mesure[Adjective] tailors tailleurs[Noun] tails queues[Noun] task tâche[Noun] tasks tâches[Noun] taste goût[Noun] tasted goûté[Verb] tasteless insipide[Adjective] tear accroc[Noun] tear de/chirer[Verb] tear de/chirure[Noun] tear larme[Noun] teardrop larme[Noun] tearful tout en pleurs[Adjective] tearfully en pleurant[Adverb] tearfully les larmes aux yeux[Adverb] teargas gaz lacrymoge\ne[Noun] tearjerker me/lo[Noun] tearless avec yeux secs[Adjective] tearless sans larmes[Adjective] tearoom salon de the/[Noun] tears de/chirures[Noun] tears larmes[Noun] tearstained barbouille/ de larmes[Adjective] tearstained portant des traces de larmes[Adjective] tease taquin[Noun] tease taquiner[Verb] tease tourmenter[Verb] teasel carde\re[Noun] teaser question dificile[Noun] teaser taquin[Noun] teases excite[Verb] teases taquine[Verb] teases taquins[Noun] teasing railleur[Adjective] teasing taquinerie[Noun] teasingly d'un ton railleur[Adverb] teasingly pour taquiner[Verb] teaspoon cuille\re a\ cafe/[Noun] teaspoon cuiller a\ cafe/[Noun] teaspoonful cuillere/e a\ cafe/[Noun] teat bout de sein[Noun] teat mamelon[Noun] teat tette[Noun] teat trayon[Noun] teatime l'heure du the/[Noun] teats mamelons[Noun] teats tettes[Noun] ten dix[Adverb] tendencies tendances (f)[Noun] tendency tendance (f)[Noun] tenderfoot visage pa^le (m)[Noun] tenderly tendrement[Adverb] thence de la\[Adverb] thence pour cette raison[Adverb] thenceforth de\s lors[Adverb] thenceforward de\s lors[Adverb] theocracy the/ocratie[Noun] theocratic the/ocratique[Adjective] theodolite the/odolite[Noun] theologian the/ologien[Noun] theologians the/ologiens theological the/ologique[Adjective] theologically the/ologiquement[Adverb] theology the/ologie[Noun] theorem the/ore\me[Noun] theorems the/ore\mes[Noun] theoretical the/ore/tique[Adjective] theoretical the/orique[Adjective] theoretically the/oriquement[Adverb] theoretician the/oricien[Noun] theoretician the/oricienne[Noun] theoreticians the/oriciennes[Noun] theoreticians the/oriciens[Noun] theories the/ories[Noun] theorist the/oricien[Noun] theorist the/oricienne[Noun] theorists the/oriciennes[Noun] theorists the/oriciens[Noun] theorize the/oriser[Verb] thief voleur[Noun] though cependant, pourtant[Adverb] though quoique , bien que[Conjunction] thought pensee,idee[Noun] thought reflexion; intention, dessein[Noun] thoughtful pensif, meditatif, reveur[Adjective] thoughtful serieux, reflechi, prudent[Adjective] thoughtfully pensivement[Adverb] thoughtfulness meditation, recueillement[Adjective] thoughtless irreflechi, etourdi[Adjective] thoughtlessly etourdiment, a la legere, sans reflexion[Adverb] thoughtlessness irreflexon, etourderie[Noun] thousand mille, millier[Noun] thousandth millieme[Noun] thrash ecraser qn, rouer qn de coup, [Verb] thrash se debattre, se demener[Verb] thread enfiler (une aiguille); se faufiler ; fileter[Verb] thread filament, fil de soie[Noun] thread Filet, pas de vis [Noun] threadbare elime, rape, use[Adjective] threat menace[Noun] threaten menacer[Verb] threatening menacant[Adjective] threateningly d'un ton menacant[Adverb] three trois[Article] tigress tiger[Noun] today au'jour d'hui[Noun] toe doigt a pied[Noun] tradition tradition[Noun] traditional traditional[Adjective] trail piste[Noun] train train[Noun] trainee stagiare[Noun] trainer encadreur[Noun] traitor trai^tre[Noun] transaction transaction[Noun] transalpine transalpin[Adjective] transcribe transcrire[Verb] transfer transfert[Noun] translate traduire[Verb] translation traduction[Noun] translator traducteur[Noun] transmit transmettre[Verb] tree arbre[Noun] truck camion two deux[Article] ubiquitous omnipre/sent[Adjective] ubiquity ubiquite/[Noun] udder pis[Noun] ugh pouah uglier plus laid[Adjective] ugliest le plus laid[Adjective] uglify enlaidir[Verb] uglily laidement ugliness laideur[Noun] ugly laid[Adjective] ukulele guitare hawai.enne[Noun] ulcer ulce\re[Noun] ulcerate ulce/rer[Verb] ulcerated ulce/reux[Adjective] ulceration ulce/ration[Noun] ulcerative ulce/ratif[Adjective] ulna cubitus[Noun] ultimo du mois dernier[Adverb] unemployment chomage[Noun] vacant (room, seat) libre; (stare) vague; (post) vacant[Adjective] vacate quitter[Verb] vacation vacances[Noun] vaccinate vacciner[Verb] vaccinated vacciner vacuum vide; (vacuum cleaner) aspirateur [masc] [Noun] vacuumed passer a\ l'aspirateur[Verb] vagina vagin (masc.)[Noun] vagrant vagabond(e) [m(f)][Noun] vague vague; (outline, photograph) flou; (absent minded) distrait[Adjective] vain (hope) vain; (promise) vide; (conceited) vaniteux, [f] -euse [Adjective] wacky drole[Adjective] wag remuer[Verb] walnut la noix[Noun] warehouse entrepot warehouse entrepôt[Noun] warehouses entrepôts[Noun] wash laver[Verb] weep pleurer[Verb] weeping pleurs[Noun] weeping qui pleure[Adjective] weeps pleure[Verb] weepy larmoyant[Adjective] weepy me/lo[Noun] weevil charanc,on[Noun] weft trame[Noun] weigh mesurer[Verb] weigh peser[Verb] weighing pese/e[Noun] weighings pese/es[Noun] weighs pe\se[Verb] weight poids[Noun] weighted leste/[Adjective] weighted ponde/re/[Adjective] weightily avec force[Adverb] weightily puissamment[Adverb] weighting lestage[Noun] weighting plombage[Noun] weightless e/tat d'apesanteur[Adjective] weightlessness apesanteur[Noun] weights attache un poids a\[Verb] weights se/rie de poids[Noun] weighty lourd[Adjective] weighty pesant[Adjective] weir barrage[Noun] weird bizarre[Adjective] weird e/trange[Adjective] weirdie excentrique[Noun] weirdies excentriques[Noun] weirdly e/trangement[Adverb] weirdness caracte\re e/trange[Noun] weirdness e/trangete/ inquie/tante[Noun] weirdo excentrique[Noun] weirdos excentriques[Noun] weirs barrages[Noun] welcome agre/able[Adjective] welcome bienvenu[Adjective] welcome bienvenue[Noun] welcome souhaiter la bienvenue a\[Verb] where ou\[Adjective] window la fene^tre[Noun] window le guichet [tickets, etc.] windowpane la glace[Noun] windowpanes les glaces windows les fene^tres windshield le parebrise[Noun] windstorm la tempe^te[Noun] windup remonter[Verb] wine le vin[Noun] wineglass le verre de vin[Noun] winegrower le vigneron[Noun] winemaker l'encaveur (m)[Noun] winemaking la vinification[Noun] winepress le pressoir[Noun] wines les vins[Noun] winey vineux (-se)[Adjective] wing l'aile (f)[Noun] winglet l'aileron (m)[Noun] wink un clin d'oeil[Noun] winter l'hiver (m) wipe essuyer wire fil me/tallique, fil de fer[Noun] wire telegramme[Noun] wire telegraphier ; faire l'installation electrique[Verb] wired branche , sonorise[Adjective] wireless sans fil[Adjective] wiring installation electrique[Noun] wiry raide, rude ; maigre et nerveux wisdom sagesse[Noun] wise sage, prudent, savant[Adjective] wisecrack astuce, sarcasme[Noun] wisely sagement, prudement[Adverb] wiser plus sage[Adjective] wish desir, souhait[Noun] wish desirer, souhaiter qch[Verb] wishbone brechet[Noun] wishes pl de wish, desir[Noun] wishful that's wishfull thinking (on your part ): tu te fais des illusions[Adjective] witch sorcie\re[Noun] witches sorcie\res[Noun] with avec[Conjunction] withdraw retirer[Verb] withdraw se retirer [intr] without sans witness te/moigner[Verb] witness te/moin[Noun] witnesses te/moins[Noun] wolverine le carcajou[Noun] wolverine le glouton[Noun] world le monde[Noun] worldwide mondial[Adjective] xenophobe xe/nophobe[Noun] xenophobia xénophobie[Noun] xenophobic xe/nophobe[Adjective] xerographic xe/rographique[Adjective] xylem xyle\me[Noun] xylene xyle\ne[Noun] xylophone xylophone[Noun] xylophones xylophone[Noun] xylophonist joueur (joueuse) de xylophone[Noun] xylose xylose[Noun] xylotomic xylotomique[Adjective] yacht yacht[Noun] yachting yachting[Noun] yachtsman yachtsman yak yack[Noun] yam patate douce[Noun] yank tirer d'un coup sec[Verb] yap japper[Verb] yard yard (3 ft)[Noun] yardstick mesure[Noun] yarn fil[Noun] yawn bâillement[Noun] yawn bâiller[Verb] yawning ba^illement[Noun] yeah ouais! year année[Noun] yearbook annuaire[Noun] yearlong annuel[Noun] yearly annuel(le)[Adjective] yearly annuellement[Adverb] yearn désirer[Verb] yearning de/sir[Noun] yearningly de/sireux[Adjective] years années[Noun] yeast levure[Noun] yell hurlement[Noun] yell hurler[Verb] yellow jaune[Adjective] yellowed jauni[Adjective] yellowing jaunissant[Adjective] yellowish jauna^tre[Adjective] yes oui yesterday hier[Noun] yet encore[Adverb] yew if[Noun] yield produire[Verb] yoga yoga[Noun] yoghurt yaourt[Noun] yogurt yaourt[Noun] yoke joug[Noun] yolk jaune d'oeuf[Noun] you (formal and/or plural) vous[Pronoun] you (informal and singular) tu[Pronoun] young jeune[Adjective] younger plus jeune[Adjective] youngster jeune[Noun] youth jeunesse[Adjective] youthful juvénile[Adjective] yuppie yuppie[Noun] zabaglione sabayon[Noun] zany dingue[Adjective] zazen zazen[Noun] zeal zèle[Noun] zealous zélé(e)[Adjective] zebra zèbre[Noun] zenith zénith[Noun] zero zero[Noun] zero zéro zest piquant[Noun] zigzag zigzaguer[Verb] zinc zinc[Noun] zipper fermeture[Noun] zodiac zodiaque[Noun] zodiac zondiaque[Noun] zone zone[Noun] zone zone[Noun] zoo zoo[Noun] zoology zoologie[Noun] zoom aller en trombe[Verb] zucchini courgette[Noun] thread3.0.1/tests/all.tcl0000644003604700454610000000330614726633451013733 0ustar dgp771div# all.tcl -- # # This file contains a top-level script to run all of the Tcl # tests. Execute it by invoking "source all.test" when running tcltest # in this directory. # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest ::tcltest::loadTestedCommands package require -exact thread 3.0.1 set ::tcltest::testSingleFile false set ::tcltest::testsDirectory [file dir [info script]] # We need to ensure that the testsDirectory is absolute ::tcltest::normalizePath ::tcltest::testsDirectory puts stdout "Tcl $tcl_patchLevel tests running in interp: [info nameofexecutable]" puts stdout "Tests running in working dir: $::tcltest::testsDirectory" if {[llength $::tcltest::skip] > 0} { puts stdout "Skipping tests that match: $::tcltest::skip" } if {[llength $::tcltest::match] > 0} { puts stdout "Only running tests that match: $::tcltest::match" } if {[llength $::tcltest::skipFiles] > 0} { puts stdout "Skipping test files that match: $::tcltest::skipFiles" } if {[llength $::tcltest::matchFiles] > 0} { puts stdout "Only sourcing test files that match: $::tcltest::matchFiles" } set timeCmd {clock format [clock seconds]} puts stdout "Tests began at [eval $timeCmd]" # These tests need to know which is the main thread set ::tcltest::mainThread [thread::id] puts stdout "thread [package provide thread]" puts stdout "Mainthread id is $::tcltest::mainThread" # Source each of the specified tests foreach file [lsort [::tcltest::getMatchingFiles]] { set tail [file tail $file] puts stdout $tail if {[catch {source $file} msg]} { puts stdout $msg } } # Cleanup puts stdout "\nTests ended at [eval $timeCmd]" ::tcltest::cleanupTests 1 return thread3.0.1/tcl/0000755003604700454610000000000014731057541012071 5ustar dgp771divthread3.0.1/tcl/tpool/0000755003604700454610000000000014731057541013226 5ustar dgp771divthread3.0.1/tcl/tpool/tpool.tcl0000644003604700454610000003057414726633451015104 0ustar dgp771div# # tpool.tcl -- # # Tcl implementation of a threadpool paradigm in pure Tcl using # the Tcl threading extension 2.5 (or higher). # # This file is for example purposes only. The efficient C-level # threadpool implementation is already a part of the threading # extension starting with 2.5 version. Both implementations have # the same Tcl API so both can be used interchangeably. Goal of # this implementation is to serve as an example of using the Tcl # extension to implement some very common threading paradigms. # # Beware: with time, as improvements are made to the C-level # implementation, this Tcl one might lag behind. # Please consider this code as a working example only. # # # # Copyright (c) 2002 by Zoran Vasiljevic. # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ----------------------------------------------------------------------------- package require thread 2.9- set thisScript [info script] namespace eval tpool { variable afterevent "" ; # Idle timer event for worker threads variable result ; # Stores result from the worker thread variable waiter ; # Waits for an idle worker thread variable jobsdone ; # Accumulates results from worker threads # # Create shared array with a single element. # It is used for automatic pool handles creation. # set ns [namespace current] tsv::lock $ns { if {[tsv::exists $ns count] == 0} { tsv::set $ns count 0 } tsv::set $ns count -1 } variable thisScript [info script] } # # tpool::create -- # # Creates instance of a thread pool. # # Arguments: # args Variable number of key/value arguments, as follows: # # -minworkers minimum # of worker threads (def:0) # -maxworkers maximum # of worker threads (def:4) # -idletime # of sec worker is idle before exiting (def:0 = never) # -initcmd script used to initialize new worker thread # -exitcmd script run at worker thread exit # # Side Effects: # Might create many new threads if "-minworkers" option is > 0. # # Results: # The id of the newly created thread pool. This id must be used # in all other tpool::* commands. # proc tpool::create {args} { variable thisScript # # Get next threadpool handle and create the pool array. # set usage "wrong \# args: should be \"[lindex [info level 1] 0]\ ?-minworkers count? ?-maxworkers count?\ ?-initcmd script? ?-exitcmd script?\ ?-idletime seconds?\"" set ns [namespace current] set tpid [namespace tail $ns][tsv::incr $ns count] tsv::lock $tpid { tsv::set $tpid name $tpid } # # Setup default pool data. # tsv::array set $tpid { thrworkers "" thrwaiters "" jobcounter 0 refcounter 0 numworkers 0 -minworkers 0 -maxworkers 4 -idletime 0 -initcmd "" -exitcmd "" } tsv::set $tpid -initcmd "source $thisScript" # # Override with user-supplied data # if {[llength $args] % 2} { error $usage } foreach {arg val} $args { switch -- $arg { -minworkers - -maxworkers {tsv::set $tpid $arg $val} -idletime {tsv::set $tpid $arg [expr {$val*1000}]} -initcmd {tsv::append $tpid $arg \n $val} -exitcmd {tsv::append $tpid $arg \n $val} default { error $usage } } } # # Start initial (minimum) number of worker threads. # for {set ii 0} {$ii < [tsv::set $tpid -minworkers]} {incr ii} { Worker $tpid } return $tpid } # # tpool::names -- # # Returns list of currently created threadpools # # Arguments: # None. # # Side Effects: # None. # # Results # List of active threadpoool identifiers or empty if none found # # proc tpool::names {} { tsv::names [namespace tail [namespace current]]* } # # tpool::post -- # # Submits the new job to the thread pool. The caller might pass # the job in two modes: synchronous and asynchronous. # For the synchronous mode, the pool implementation will retain # the result of the passed script until the caller collects it # using the "thread::get" command. # For the asynchronous mode, the result of the script is ignored. # # Arguments: # args Variable # of arguments with the following syntax: # tpool::post ?-detached? tpid script # # -detached flag to turn the async operation (ignore result) # tpid the id of the thread pool # script script to pass to the worker thread for execution # # Side Effects: # Depends on the passed script. # # Results: # The id of the posted job. This id is used later on to collect # result of the job and set local variables accordingly. # For asynchronously posted jobs, the return result is ignored # and this function returns empty result. # proc tpool::post {args} { # # Parse command arguments. # set ns [namespace current] set usage "wrong \# args: should be \"[lindex [info level 1] 0]\ ?-detached? tpoolId script\"" if {[llength $args] == 2} { set detached 0 set tpid [lindex $args 0] set cmd [lindex $args 1] } elseif {[llength $args] == 3} { if {[lindex $args 0] != "-detached"} { error $usage } set detached 1 set tpid [lindex $args 1] set cmd [lindex $args 2] } else { error $usage } # # Find idle (or create new) worker thread. This is relatively # a complex issue, since we must honour the limits about number # of allowed worker threads imposed to us by the caller. # set tid "" while {$tid == ""} { tsv::lock $tpid { set tid [tsv::lpop $tpid thrworkers] if {$tid == "" || [catch {thread::preserve $tid}]} { set tid "" tsv::lpush $tpid thrwaiters [thread::id] end if {[tsv::set $tpid numworkers]<[tsv::set $tpid -maxworkers]} { Worker $tpid } } } if {$tid == ""} { vwait ${ns}::waiter } } # # Post the command to the worker thread # if {$detached} { set j "" thread::send -async $tid [list ${ns}::Run $tpid 0 $cmd] } else { set j [tsv::incr $tpid jobcounter] thread::send -async $tid [list ${ns}::Run $tpid $j $cmd] ${ns}::result } variable jobsdone set jobsdone($j) "" return $j } # # tpool::wait -- # # Waits for jobs sent with "thread::post" to finish. # # Arguments: # tpid Name of the pool shared array. # jobList List of job id's done. # jobLeft List of jobs still pending. # # Side Effects: # Might eventually enter the event loop while waiting # for the job result to arrive from the worker thread. # It ignores bogus job ids. # # Results: # Result of the job. If the job resulted in error, it sets # the global errorInfo and errorCode variables accordingly. # proc tpool::wait {tpid jobList {jobLeft ""}} { variable result variable jobsdone if {$jobLeft != ""} { upvar $jobLeft jobleft } set retlist "" set jobleft "" foreach j $jobList { if {[info exists jobsdone($j)] == 0} { continue ; # Ignore (skip) bogus job ids } if {$jobsdone($j) != ""} { lappend retlist $j } else { lappend jobleft $j } } if {[llength $retlist] == 0 && [llength $jobList]} { # # No jobs found; wait for the first one to get ready. # set jobleft $jobList while {1} { vwait [namespace current]::result set doneid [lindex $result 0] set jobsdone($doneid) $result if {[lsearch $jobList $doneid] >= 0} { lappend retlist $doneid set x [lsearch $jobleft $doneid] set jobleft [lreplace $jobleft $x $x] break } } } return $retlist } # # tpool::get -- # # Waits for a job sent with "thread::post" to finish. # # Arguments: # tpid Name of the pool shared array. # jobid Id of the previously posted job. # # Side Effects: # None. # # Results: # Result of the job. If the job resulted in error, it sets # the global errorInfo and errorCode variables accordingly. # proc tpool::get {tpid jobid} { variable jobsdone if {[lindex $jobsdone($jobid) 1] != 0} { eval error [lrange $jobsdone($jobid) 2 end] } return [lindex $jobsdone($jobid) 2] } # # tpool::preserve -- # # Increments the reference counter of the threadpool, reserving it # for the private usage.. # # Arguments: # tpid Name of the pool shared array. # # Side Effects: # None. # # Results: # Current number of threadpool reservations. # proc tpool::preserve {tpid} { tsv::incr $tpid refcounter } # # tpool::release -- # # Decrements the reference counter of the threadpool, eventually # tearing the pool down if this was the last reservation. # # Arguments: # tpid Name of the pool shared array. # # Side Effects: # If the number of reservations drops to zero or below # the threadpool is teared down. # # Results: # Current number of threadpool reservations. # proc tpool::release {tpid} { tsv::lock $tpid { if {[tsv::incr $tpid refcounter -1] <= 0} { # Release all workers threads foreach t [tsv::set $tpid thrworkers] { thread::release -wait $t } tsv::unset $tpid ; # This is not an error; it works! } } } # # Private procedures, not a part of the threadpool API. # # # tpool::Worker -- # # Creates new worker thread. This procedure must be executed # under the tsv lock. # # Arguments: # tpid Name of the pool shared array. # # Side Effects: # Depends on the thread initialization script. # # Results: # None. # proc tpool::Worker {tpid} { # # Create new worker thread # set tid [thread::create] thread::send $tid [tsv::set $tpid -initcmd] thread::preserve $tid tsv::incr $tpid numworkers tsv::lpush $tpid thrworkers $tid # # Signalize waiter threads if any # set waiter [tsv::lpop $tpid thrwaiters] if {$waiter != ""} { thread::send -async $waiter [subst { set [namespace current]::waiter 1 }] } } # # tpool::Timer -- # # This procedure should be executed within the worker thread only. # It registers the callback for terminating the idle thread. # # Arguments: # tpid Name of the pool shared array. # # Side Effects: # Thread may eventually exit. # # Results: # None. # proc tpool::Timer {tpid} { tsv::lock $tpid { if {[tsv::set $tpid numworkers] > [tsv::set $tpid -minworkers]} { # # We have more workers than needed, so kill this one. # We first splice ourselves from the list of active # workers, adjust the number of workers and release # this thread, which may exit eventually. # set x [tsv::lsearch $tpid thrworkers [thread::id]] if {$x >= 0} { tsv::lreplace $tpid thrworkers $x $x tsv::incr $tpid numworkers -1 set exitcmd [tsv::set $tpid -exitcmd] if {$exitcmd != ""} { catch {eval $exitcmd} } thread::release } } } } # # tpool::Run -- # # This procedure should be executed within the worker thread only. # It performs the actual command execution in the worker thread. # # Arguments: # tpid Name of the pool shared array. # jid The job id # cmd The command to execute # # Side Effects: # Many, depending of the passed command # # Results: # List for passing the evaluation result and status back. # proc tpool::Run {tpid jid cmd} { # # Cancel the idle timer callback, if any. # variable afterevent if {$afterevent != ""} { after cancel $afterevent } # # Evaluate passed command and build the result list. # set code [catch {uplevel \#0 $cmd} ret] if {$code == 0} { set res [list $jid 0 $ret] } else { set res [list $jid $code $ret $::errorInfo $::errorCode] } # # Check to see if any caller is waiting to be serviced. # If yes, kick it out of the waiting state. # set ns [namespace current] tsv::lock $tpid { tsv::lpush $tpid thrworkers [thread::id] set waiter [tsv::lpop $tpid thrwaiters] if {$waiter != ""} { thread::send -async $waiter [subst { set ${ns}::waiter 1 }] } } # # Release the thread. If this turns out to be # the last refcount held, don't bother to do # any more work, since thread will soon exit. # if {[thread::release] <= 0} { return $res } # # Register the idle timer again. # if {[set idle [tsv::set $tpid -idletime]]} { set afterevent [after $idle [subst { ${ns}::Timer $tpid }]] } return $res } # EOF $RCSfile: tpool.tcl,v $ # Emacs Setup Variables # Local Variables: # mode: Tcl # indent-tabs-mode: nil # tcl-basic-offset: 4 # End: thread3.0.1/tcl/phttpd/0000755003604700454610000000000014731057541013374 5ustar dgp771divthread3.0.1/tcl/phttpd/uhttpd.tcl0000644003604700454610000002152114726633451015415 0ustar dgp771div# # uhttpd.tcl -- # # Simple Sample httpd/1.0 server in 250 lines of Tcl. # Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems. # # Modified to use namespaces and direct url-to-procedure access (zv). # Eh, due to this, and nicer indenting, it's now 150 lines longer :-) # # Usage: # phttpd::create port # # port Tcp port where the server listens # # Example: # # # tclsh9.0 # % source uhttpd.tcl # % uhttpd::create 5000 # % vwait forever # # Starts the server on the port 5000. Also, look at the Httpd array # definition in the "uhttpd" namespace declaration to find out # about other options you may put on the command line. # # You can use: http://localhost:5000/monitor URL to test the # server functionality. # # Copyright (c) Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems. # Copyright (c) 2002 by Zoran Vasiljevic. # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ----------------------------------------------------------------------------- namespace eval uhttpd { variable Httpd; # Internal server state and config params variable MimeTypes; # Cache of file-extension/mime-type variable HttpCodes; # Portion of well-known http return codes variable ErrorPage; # Format of error response page in html array set Httpd { -name uhttpd -vers 1.0 -root "" -index index.htm } array set HttpCodes { 400 "Bad Request" 401 "Not Authorized" 404 "Not Found" 500 "Server error" } array set MimeTypes { {} "text/plain" .txt "text/plain" .htm "text/html" .htm "text/html" .gif "image/gif" .jpg "image/jpeg" .png "image/png" } set ErrorPage { Error: %1$s %2$s

%3$s

Problem in accessing "%4$s" on this server.

%5$s/%6$s Server at %7$s Port %8$s } } proc uhttpd::create {port args} { # @c Start the server by listening for connections on the desired port. variable Httpd set arglen [llength $args] if {$arglen} { if {$arglen % 2} { error "wrong \# arguments, should be: key1 val1 key2 val2..." } set opts [array names Httpd] foreach {arg val} $args { if {[lsearch $opts $arg] < 0} { error "unknown option \"$arg\"" } set Httpd($arg) $val } } set Httpd(port) $port set Httpd(host) [info hostname] socket -server [namespace current]::Accept $port } proc uhttpd::respond {s status contype data {length 0}} { puts $s "HTTP/1.0 $status" puts $s "Date: [Date]" puts $s "Content-Type: $contype" if {$length} { puts $s "Content-Length: $length" } else { puts $s "Content-Length: [string length $data]" } puts $s "" puts $s $data } proc uhttpd::Accept {newsock ipaddr port} { # @c Accept a new connection from the client. variable Httpd upvar \#0 [namespace current]::Httpd$newsock data fconfigure $newsock -blocking 0 -translation {auto crlf} set data(ipaddr) $ipaddr fileevent $newsock readable [list [namespace current]::Read $newsock] } proc uhttpd::Read {s} { # @c Read data from client variable Httpd upvar \#0 [namespace current]::Httpd$s data if {[catch {gets $s line} readCount] || [eof $s]} { return [Done $s] } if {$readCount < 0} { return ;# Insufficient data on non-blocking socket ! } if {![info exists data(state)]} { set pat {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1\.[0-9]} if {[regexp $pat $line x data(proto) data(url) data(query)]} { return [set data(state) mime] } else { Log error "bad request line: %s" $line Error $s 400 return [Done $s] } } # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 set state [string compare $readCount 0],$data(state),$data(proto) switch -- $state { "0,mime,GET" - "0,query,POST" { Respond $s } "0,mime,POST" { set data(state) query set data(query) "" } "1,mime,POST" - "1,mime,GET" { if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { set data(mime,[string tolower $key]) $value } } "1,query,POST" { append data(query) $line set clen $data(mime,content-length) if {($clen - [string length $data(query)]) <= 0} { Respond $s } } default { if [eof $s] { Log error "unexpected eof; client closed connection" return [Done $s] } else { Log error "bad http protocol state: %s" $state Error $s 400 return [Done $s] } } } } proc uhttpd::Done {s} { # @c Close the connection socket and discard token close $s unset [namespace current]::Httpd$s } proc uhttpd::Respond {s} { # @c Respond to the query. variable Httpd upvar \#0 [namespace current]::Httpd$s data if {[uplevel \#0 info proc $data(url)] == $data(url)} { # # Service URL-procedure first # if {[catch { puts $s "HTTP/1.0 200 OK" puts $s "Date: [Date]" puts $s "Last-Modified: [Date]" } err]} { Log error "client closed connection prematurely: %s" $err return [Done $s] } set data(sock) $s if {[catch {$data(url) data} err]} { Log error "%s: %s" $data(url) $err } } else { # # Service regular file path next. # set mypath [Url2File $data(url)] if {![catch {open $mypath} i]} { if {[catch { puts $s "HTTP/1.0 200 OK" puts $s "Date: [Date]" puts $s "Last-Modified: [Date [file mtime $mypath]]" puts $s "Content-Type: [ContentType $mypath]" puts $s "Content-Length: [file size $mypath]" puts $s "" fconfigure $s -translation binary -blocking 0 fconfigure $i -translation binary fcopy $i $s close $i } err]} { Log error "client closed connection prematurely: %s" $err } } else { Log error "%s: %s" $data(url) $i Error $s 404 } } Done $s } proc uhttpd::ContentType {path} { # @c Convert the file suffix into a mime type. variable MimeTypes set type "text/plain" catch {set type $MimeTypes([file extension $path])} return $type } proc uhttpd::Error {s code} { # @c Emit error page. variable Httpd variable HttpCodes variable ErrorPage upvar \#0 [namespace current]::Httpd$s data append data(url) "" set msg \ [format $ErrorPage \ $code \ $HttpCodes($code) \ $HttpCodes($code) \ $data(url) \ $Httpd(-name) \ $Httpd(-vers) \ $Httpd(host) \ $Httpd(port) \ ] if {[catch { puts $s "HTTP/1.0 $code $HttpCodes($code)" puts $s "Date: [Date]" puts $s "Content-Length: [string length $msg]" puts $s "" puts $s $msg } err]} { Log error "client closed connection prematurely: %s" $err } } proc uhttpd::Date {{seconds 0}} { # @c Generate a date string in HTTP format. if {$seconds == 0} { set seconds [clock seconds] } clock format $seconds -format {%a, %d %b %Y %T %Z} -gmt 1 } proc uhttpd::Log {reason format args} { # @c Log an httpd transaction. set messg [eval format [list $format] $args] set stamp [clock format [clock seconds] -format "%d/%b/%Y:%H:%M:%S"] puts stderr "\[$stamp\] $reason: $messg" } proc uhttpd::Url2File {url} { # @c Convert a url into a pathname (this is probably not right) variable Httpd lappend pathlist $Httpd(-root) set level 0 foreach part [split $url /] { set part [CgiMap $part] if [regexp {[:/]} $part] { return "" } switch -- $part { "." { } ".." {incr level -1} default {incr level} } if {$level <= 0} { return "" } lappend pathlist $part } set file [eval file join $pathlist] if {[file isdirectory $file]} { return [file join $file $Httpd(-index)] } else { return $file } } proc uhttpd::CgiMap {data} { # @c Decode url-encoded strings regsub -all {\+} $data { } data regsub -all {([][$\\])} $data {\\\1} data regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data return [subst $data] } proc uhttpd::QueryMap {query} { # @c Decode url-encoded query into key/value pairs set res [list] regsub -all {[&=]} $query { } query regsub -all { } $query { {} } query; # Othewise we lose empty values foreach {key val} $query { lappend res [CgiMap $key] [CgiMap $val] } return $res } proc /monitor {array} { upvar $array data ; # Holds the socket to remote client # # Emit headers # puts $data(sock) "HTTP/1.0 200 OK" puts $data(sock) "Date: [uhttpd::Date]" puts $data(sock) "Content-Type: text/html" puts $data(sock) "" # # Emit body # puts $data(sock) [subst {

[clock format [clock seconds]]

}] after 1 ; # Simulate blocking call puts $data(sock) [subst { }] } # EOF $RCSfile: uhttpd.tcl,v $ # Emacs Setup Variables # Local Variables: # mode: Tcl # indent-tabs-mode: nil # tcl-basic-offset: 4 # End: thread3.0.1/tcl/phttpd/phttpd.tcl0000644003604700454610000002742514726633451015421 0ustar dgp771div# # phttpd.tcl -- # # Simple Sample httpd/1.0 server in 250 lines of Tcl. # Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems. # # Modified to use namespaces, direct url-to-procedure access # and thread pool package. Grown little larger since ;) # # Usage: # phttpd::create port # # port Tcp port where the server listens # # Example: # # # tclsh9.0 # % source phttpd.tcl # % phttpd::create 5000 # % vwait forever # # Starts the server on the port 5000. Also, look at the Httpd array # definition in the "phttpd" namespace declaration to find out # about other options you may put on the command line. # # You can use: http://localhost:5000/monitor URL to test the # server functionality. # # Copyright (c) 2002 by Zoran Vasiljevic. # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ----------------------------------------------------------------------------- package require Tcl 8.5- package require thread 2.9- # # Modify the following in order to load the # example Tcl implementation of threadpools. # Per default, the C-level threadpool is used. # if {0} { eval [set TCL_TPOOL {source ../tpool/tpool.tcl}] } namespace eval phttpd { variable Httpd; # Internal server state and config params variable MimeTypes; # Cache of file-extension/mime-type variable HttpCodes; # Portion of well-known http return codes variable ErrorPage; # Format of error response page in html array set Httpd { -name phttpd -vers 1.0 -root "." -index index.htm } array set HttpCodes { 400 "Bad Request" 401 "Not Authorized" 404 "Not Found" 500 "Server error" } array set MimeTypes { {} "text/plain" .txt "text/plain" .htm "text/html" .htm "text/html" .gif "image/gif" .jpg "image/jpeg" .png "image/png" } set ErrorPage { Error: %1$s %2$s

%3$s

Problem in accessing "%4$s" on this server.

%5$s/%6$s Server at %7$s Port %8$s } } # # phttpd::create -- # # Start the server by listening for connections on the desired port. # # Arguments: # port # args # # Side Effects: # None.. # # Results: # None. # proc phttpd::create {port args} { variable Httpd set arglen [llength $args] if {$arglen} { if {$arglen % 2} { error "wrong \# args, should be: key1 val1 key2 val2..." } set opts [array names Httpd] foreach {arg val} $args { if {[lsearch $opts $arg] < 0} { error "unknown option \"$arg\"" } set Httpd($arg) $val } } # # Create thread pool with max 8 worker threads. # if {[info exists ::TCL_TPOOL] == 0} { # # Using the internal C-based thread pool # set initcmd "source ../phttpd/phttpd.tcl" } else { # # Using the Tcl-level hand-crafted thread pool # append initcmd "source ../phttpd/phttpd.tcl" \n $::TCL_TPOOL } set Httpd(tpid) [tpool::create -maxworkers 8 -initcmd $initcmd] # # Start the server on the given port. Note that we wrap # the actual accept with a helper after/idle callback. # This is a workaround for a well-known Tcl bug. # socket -server [namespace current]::_Accept $port } # # phttpd::_Accept -- # # Helper procedure to solve Tcl shared-channel bug when responding # to incoming connection and transfering the channel to other thread(s). # # Arguments: # sock incoming socket # ipaddr IP address of the remote peer # port Tcp port used for this connection # # Side Effects: # None. # # Results: # None. # proc phttpd::_Accept {sock ipaddr port} { after idle [list [namespace current]::Accept $sock $ipaddr $port] } # # phttpd::Accept -- # # Accept a new connection from the client. # # Arguments: # sock # ipaddr # port # # Side Effects: # None.. # # Results: # None. # proc phttpd::Accept {sock ipaddr port} { variable Httpd # # Setup the socket for sane operation # fconfigure $sock -blocking 0 -translation {auto crlf} # # Detach the socket from current interpreter/tnread. # One of the worker threads will attach it again. # thread::detach $sock # # Send the work ticket to threadpool. # tpool::post -detached $Httpd(tpid) [list [namespace current]::Ticket $sock] } # # phttpd::Ticket -- # # Job ticket to run in the thread pool thread. # # Arguments: # sock # # Side Effects: # None.. # # Results: # None. # proc phttpd::Ticket {sock} { thread::attach $sock fileevent $sock readable [list [namespace current]::Read $sock] # # End of processing is signalized here. # This will release the worker thread. # vwait [namespace current]::done } # # phttpd::Read -- # # Read data from client and parse incoming http request. # # Arguments: # sock # # Side Effects: # None. # # Results: # None. # proc phttpd::Read {sock} { variable Httpd variable data set data(sock) $sock while {1} { if {[catch {gets $data(sock) line} readCount] || [eof $data(sock)]} { return [Done] } if {![info exists data(state)]} { set pat {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1\.[0-9]} if {[regexp $pat $line x data(proto) data(url) data(query)]} { set data(state) mime continue } else { Log error "bad request line: (%s)" $line Error 400 return [Done] } } # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 set state [string compare $readCount 0],$data(state),$data(proto) switch -- $state { "0,mime,GET" - "0,query,POST" { Respond return [Done] } "0,mime,POST" { set data(state) query set data(query) "" } "1,mime,POST" - "1,mime,GET" { if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { set data(mime,[string tolower $key]) $value } } "1,query,POST" { append data(query) $line set clen $data(mime,content-length) if {($clen - [string length $data(query)]) <= 0} { Respond return [Done] } } default { if [eof $data(sock)] { Log error "unexpected eof; client closed connection" return [Done] } else { Log error "bad http protocol state: %s" $state Error 400 return [Done] } } } } } # # phttpd::Done -- # # Close the connection socket # # Arguments: # s # # Side Effects: # None.. # # Results: # None. # proc phttpd::Done {} { variable done variable data close $data(sock) if {[info exists data]} { unset data } set done 1 ; # Releases the request thread (See Ticket procedure) } # # phttpd::Respond -- # # Respond to the query. # # Arguments: # s # # Side Effects: # None.. # # Results: # None. # proc phttpd::Respond {} { variable data if {[info commands $data(url)] == $data(url)} { # # Service URL-procedure # if {[catch { puts $data(sock) "HTTP/1.0 200 OK" puts $data(sock) "Date: [Date]" puts $data(sock) "Last-Modified: [Date]" } err]} { Log error "client closed connection prematurely: %s" $err return } if {[catch {$data(url) data} err]} { Log error "%s: %s" $data(url) $err } } else { # # Service regular file path # set mypath [Url2File $data(url)] if {![catch {open $mypath} i]} { if {[catch { puts $data(sock) "HTTP/1.0 200 OK" puts $data(sock) "Date: [Date]" puts $data(sock) "Last-Modified: [Date [file mtime $mypath]]" puts $data(sock) "Content-Type: [ContentType $mypath]" puts $data(sock) "Content-Length: [file size $mypath]" puts $data(sock) "" fconfigure $data(sock) -translation binary -blocking 0 fconfigure $i -translation binary fcopy $i $data(sock) close $i } err]} { Log error "client closed connection prematurely: %s" $err } } else { Log error "%s: %s" $data(url) $i Error 404 } } } # # phttpd::ContentType -- # # Convert the file suffix into a mime type. # # Arguments: # path # # Side Effects: # None.. # # Results: # None. # proc phttpd::ContentType {path} { # @c Convert the file suffix into a mime type. variable MimeTypes set type "text/plain" catch {set type $MimeTypes([file extension $path])} return $type } # # phttpd::Error -- # # Emit error page # # Arguments: # s # code # # Side Effects: # None.. # # Results: # None. # proc phttpd::Error {code} { variable Httpd variable HttpCodes variable ErrorPage variable data append data(url) "" set msg \ [format $ErrorPage \ $code \ $HttpCodes($code) \ $HttpCodes($code) \ $data(url) \ $Httpd(-name) \ $Httpd(-vers) \ [info hostname] \ 80 \ ] if {[catch { puts $data(sock) "HTTP/1.0 $code $HttpCodes($code)" puts $data(sock) "Date: [Date]" puts $data(sock) "Content-Length: [string length $msg]" puts $data(sock) "" puts $data(sock) $msg } err]} { Log error "client closed connection prematurely: %s" $err } } # # phttpd::Date -- # # Generate a date string in HTTP format. # # Arguments: # seconds # # Side Effects: # None.. # # Results: # None. # proc phttpd::Date {{seconds 0}} { # @c Generate a date string in HTTP format. if {$seconds == 0} { set seconds [clock seconds] } clock format $seconds -format {%a, %d %b %Y %T %Z} -gmt 1 } # # phttpd::Log -- # # Log an httpd transaction. # # Arguments: # reason # format # args # # Side Effects: # None.. # # Results: # None. # proc phttpd::Log {reason format args} { set messg [eval format [list $format] $args] set stamp [clock format [clock seconds] -format "%d/%b/%Y:%H:%M:%S"] puts stderr "\[$stamp\]\[-thread[thread::id]-\] $reason: $messg" } # # phttpd::Url2File -- # # Convert a url into a pathname. # # Arguments: # url # # Side Effects: # None.. # # Results: # None. # proc phttpd::Url2File {url} { variable Httpd lappend pathlist $Httpd(-root) set level 0 foreach part [split $url /] { set part [CgiMap $part] if [regexp {[:/]} $part] { return "" } switch -- $part { "." { } ".." {incr level -1} default {incr level} } if {$level <= 0} { return "" } lappend pathlist $part } set file [eval file join $pathlist] if {[file isdirectory $file]} { return [file join $file $Httpd(-index)] } else { return $file } } # # phttpd::CgiMap -- # # Decode url-encoded strings. # # Arguments: # data # # Side Effects: # None.. # # Results: # None. # proc phttpd::CgiMap {data} { regsub -all {\+} $data { } data regsub -all {([][$\\])} $data {\\\1} data regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data return [subst $data] } # # phttpd::QueryMap -- # # Decode url-encoded query into key/value pairs. # # Arguments: # query # # Side Effects: # None.. # # Results: # None. # proc phttpd::QueryMap {query} { set res [list] regsub -all {[&=]} $query { } query regsub -all { } $query { {} } query; # Othewise we lose empty values foreach {key val} $query { lappend res [CgiMap $key] [CgiMap $val] } return $res } # # monitor -- # # Procedure used to test the phttpd server. It responds on the # http://:/monitor # # Arguments: # array # # Side Effects: # None.. # # Results: # None. # proc /monitor {array} { upvar $array data ; # Holds the socket to remote client # # Emit headers # puts $data(sock) "HTTP/1.0 200 OK" puts $data(sock) "Date: [phttpd::Date]" puts $data(sock) "Content-Type: text/html" puts $data(sock) "" # # Emit body # puts $data(sock) [subst {

[clock format [clock seconds]]

}] after 1 ; # Simulate blocking call puts $data(sock) [subst { }] } # EOF $RCSfile: phttpd.tcl,v $ # Emacs Setup Variables # Local Variables: # mode: Tcl # indent-tabs-mode: nil # tcl-basic-offset: 4 # End: thread3.0.1/tcl/phttpd/index.htm0000644003604700454610000000006314726633451015220 0ustar dgp771div

Hallo World

thread3.0.1/tcl/cmdsrv/0000755003604700454610000000000014731057541013367 5ustar dgp771divthread3.0.1/tcl/cmdsrv/cmdsrv.tcl0000644003604700454610000001336714726633451015407 0ustar dgp771div# # cmdsrv.tcl -- # # Simple socket command server. Supports many simultaneous sessions. # Works in thread mode with each new connection receiving a new thread. # # Usage: # cmdsrv::create port ?-idletime value? ?-initcmd cmd? # # port Tcp port where the server listens # -idletime # of sec to idle before tearing down socket (def: 300 sec) # -initcmd script to initialize new worker thread (def: empty) # # Example: # # # tclsh9.0 # % source cmdsrv.tcl # % cmdsrv::create 5000 -idletime 60 # % vwait forever # # Starts the server on the port 5000, sets idle timer to 1 minute. # You can now use "telnet" utility to connect. # # Copyright (c) 2002 by Zoran Vasiljevic. # # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ----------------------------------------------------------------------------- package require Tcl 8.5- package require thread 2.9- namespace eval cmdsrv { variable data; # Stores global configuration options } # # cmdsrv::create -- # # Start the server on the given Tcp port. # # Arguments: # port Port where the server is listening # args Variable number of arguments # # Side Effects: # None. # # Results: # None. # proc cmdsrv::create {port args} { variable data if {[llength $args] % 2} { error "wrong \# arguments, should be: key1 val1 key2 val2..." } # # Setup default pool data. # array set data { -idletime 300000 -initcmd {source cmdsrv.tcl} } # # Override with user-supplied data # foreach {arg val} $args { switch -- $arg { -idletime {set data($arg) [expr {$val*1000}]} -initcmd {append data($arg) \n $val} default { error "unsupported pool option \"$arg\"" } } } # # Start the server on the given port. Note that we wrap # the actual accept with a helper after/idle callback. # This is a workaround for a well-known Tcl bug. # socket -server [namespace current]::_Accept -myaddr 127.0.0.1 $port } # # cmdsrv::_Accept -- # # Helper procedure to solve Tcl shared channel bug when responding # to incoming socket connection and transfering the channel to other # thread(s). # # Arguments: # s incoming socket # ipaddr IP address of the remote peer # port Tcp port used for this connection # # Side Effects: # None. # # Results: # None. # proc cmdsrv::_Accept {s ipaddr port} { after idle [list [namespace current]::Accept $s $ipaddr $port] } # # cmdsrv::Accept -- # # Accepts the incoming socket connection, creates the worker thread. # # Arguments: # s incoming socket # ipaddr IP address of the remote peer # port Tcp port used for this connection # # Side Effects: # Creates new worker thread. # # Results: # None. # proc cmdsrv::Accept {s ipaddr port} { variable data # # Configure socket for sane operation # fconfigure $s -blocking 0 -buffering none -translation {auto crlf} # # Emit the prompt # puts -nonewline $s "% " # # Create worker thread and transfer socket ownership # set tid [thread::create [append data(-initcmd) \n thread::wait]] thread::transfer $tid $s ; # This flushes the socket as well # # Start event-loop processing in the remote thread # thread::send -async $tid [subst { array set [namespace current]::data {[array get data]} fileevent $s readable {[namespace current]::Read $s} proc exit args {[namespace current]::SockDone $s} [namespace current]::StartIdleTimer $s }] } # # cmdsrv::Read -- # # Event loop procedure to read data from socket and collect the # command to execute. If the command read from socket is complete # it executes the command are prints the result back. # # Arguments: # s incoming socket # # Side Effects: # None. # # Results: # None. # proc cmdsrv::Read {s} { variable data StopIdleTimer $s # # Cover client closing connection # if {[eof $s] || [catch {read $s} line]} { return [SockDone $s] } if {$line == "\n" || $line == ""} { if {[catch {puts -nonewline $s "% "}]} { return [SockDone $s] } return [StartIdleTimer $s] } # # Construct command line to eval # append data(cmd) $line if {[info complete $data(cmd)] == 0} { if {[catch {puts -nonewline $s "> "}]} { return [SockDone $s] } return [StartIdleTimer $s] } # # Run the command # catch {uplevel \#0 $data(cmd)} ret if {[catch {puts $s $ret}]} { return [SockDone $s] } set data(cmd) "" if {[catch {puts -nonewline $s "% "}]} { return [SockDone $s] } StartIdleTimer $s } # # cmdsrv::SockDone -- # # Tears down the thread and closes the socket if the remote peer has # closed his side of the comm channel. # # Arguments: # s incoming socket # # Side Effects: # Worker thread gets released. # # Results: # None. # proc cmdsrv::SockDone {s} { catch {close $s} thread::release } # # cmdsrv::StopIdleTimer -- # # Cancel the connection idle timer. # # Arguments: # s incoming socket # # Side Effects: # After event gets cancelled. # # Results: # None. # proc cmdsrv::StopIdleTimer {s} { variable data if {[info exists data(idleevent)]} { after cancel $data(idleevent) unset data(idleevent) } } # # cmdsrv::StartIdleTimer -- # # Initiates the connection idle timer. # # Arguments: # s incoming socket # # Side Effects: # After event gets posted. # # Results: # None. # proc cmdsrv::StartIdleTimer {s} { variable data set data(idleevent) \ [after $data(-idletime) [list [namespace current]::SockDone $s]] } # EOF $RCSfile: cmdsrv.tcl,v $ # Emacs Setup Variables # Local Variables: # mode: Tcl # indent-tabs-mode: nil # tcl-basic-offset: 4 # End: thread3.0.1/tcl/README0000644003604700454610000000244614726633451012763 0ustar dgp771div Software here is provided as example of making some interesting things and applications using the Tcl threading extension. Currently, following packages are supplied: tpool/ Example Tcl-only implementation of thread pools. The threading extension includes an efficient threadpool implementation in C. This file is provided as a fully functional example on how this functionality could be implemented in Tcl alone. phttpd/ MT-enabled httpd server. It uses threadpool to distribute incoming requests among several worker threads in the threadpool. This way blocking requests may be handled much better, w/o halting the event loop of the main responder thread. In this directory you will also find the uhttpd. This is the same web-server but operating in the event-loop mode alone, no threadpool support. This is good for comparison purposes. cmdsrv/ Socket command-line server. Each new connection gets new thread, thus allowing multiple outstanding blocking calls without halting the event loop. To play around with above packages, change to the corresponding directory and source files in the Tcl8.7 (or later) Tcl shell. Be sure to have the latest Tcl threading extension installed in your package path. - EOF thread3.0.1/win/0000755003604700454610000000000014731057540012103 5ustar dgp771divthread3.0.1/win/thread_win.dsp0000644003604700454610000001337314726633451014753 0ustar dgp771div# Microsoft Developer Studio Project File - Name="thread" - Package Owner=<4> # Microsoft Developer Studio Generated Build File, Format Version 6.00 # ** DO NOT EDIT ** # TARGTYPE "Win32 (x86) External Target" 0x0106 CFG=thread - Win32 Debug !MESSAGE This is not a valid makefile. To build this project using NMAKE, !MESSAGE use the Export Makefile command and run !MESSAGE !MESSAGE NMAKE /f "thread_win.mak". !MESSAGE !MESSAGE You can specify a configuration when running NMAKE !MESSAGE by defining the macro CFG on the command line. For example: !MESSAGE !MESSAGE NMAKE /f "thread_win.mak" CFG="thread - Win32 Debug" !MESSAGE !MESSAGE Possible choices for configuration are: !MESSAGE !MESSAGE "thread - Win32 Release" (based on "Win32 (x86) External Target") !MESSAGE "thread - Win32 Debug" (based on "Win32 (x86) External Target") !MESSAGE # Begin Project # PROP AllowPerConfigDependencies 0 # PROP Scc_ProjName "" # PROP Scc_LocalPath "" !IF "$(CFG)" == "thread - Win32 Release" # PROP BASE Use_MFC 0 # PROP BASE Use_Debug_Libraries 0 # PROP BASE Output_Dir "Release" # PROP BASE Intermediate_Dir "Release" # PROP BASE Cmd_Line "NMAKE /f thread.mak" # PROP BASE Rebuild_Opt "/a" # PROP BASE Target_File "thread.exe" # PROP BASE Bsc_Name "thread.bsc" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 0 # PROP Output_Dir "Release" # PROP Intermediate_Dir "Release" # PROP Cmd_Line "nmake -nologo -f makefile.vc TCLDIR=E:\tcl MSVCDIR=IDE" # PROP Rebuild_Opt "-a" # PROP Target_File "Release\thread27.dll" # PROP Bsc_Name "" # PROP Target_Dir "" !ELSEIF "$(CFG)" == "thread - Win32 Debug" # PROP BASE Use_MFC 0 # PROP BASE Use_Debug_Libraries 1 # PROP BASE Output_Dir "Debug" # PROP BASE Intermediate_Dir "Debug" # PROP BASE Cmd_Line "NMAKE /f thread.mak" # PROP BASE Rebuild_Opt "/a" # PROP BASE Target_File "thread.exe" # PROP BASE Bsc_Name "thread.bsc" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 1 # PROP Output_Dir "Debug" # PROP Intermediate_Dir "Debug" # PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols TCLDIR=E:\tcl MSVCDIR=IDE" # PROP Rebuild_Opt "-a" # PROP Target_File "Debug\thread27d.dll" # PROP Bsc_Name "" # PROP Target_Dir "" !ENDIF # Begin Target # Name "thread - Win32 Release" # Name "thread - Win32 Debug" !IF "$(CFG)" == "thread - Win32 Release" !ELSEIF "$(CFG)" == "thread - Win32 Debug" !ENDIF ROOT=.. # Begin Group "generic" # PROP Default_Filter "" # Begin Source File SOURCE=$(ROOT)\generic\threadNs.c # End Source File # Begin Source File SOURCE=$(ROOT)\generic\psGdbm.c # End Source File # Begin Source File SOURCE=$(ROOT)\generic\psGdbm.h # End Source File # Begin Source File SOURCE=$(ROOT)\generic\tclThread.h # End Source File # Begin Source File SOURCE=$(ROOT)\generic\tclThreadInt.h # End Source File # Begin Source File SOURCE=$(ROOT)\generic\tclXkeylist.c # End Source File # Begin Source File SOURCE=$(ROOT)\generic\tclXkeylist.h # End Source File # Begin Source File SOURCE=$(ROOT)\generic\threadCmd.c # End Source File # Begin Source File SOURCE=$(ROOT)\generic\threadPoolCmd.c # End Source File # Begin Source File SOURCE=$(ROOT)\generic\threadSpCmd.c # End Source File # Begin Source File SOURCE=$(ROOT)\generic\threadSvCmd.c # End Source File # Begin Source File SOURCE=$(ROOT)\generic\threadSvCmd.h # End Source File # Begin Source File SOURCE=$(ROOT)\generic\threadSvKeylistCmd.c # End Source File # Begin Source File SOURCE=$(ROOT)\generic\threadSvKeylistCmd.h # End Source File # Begin Source File SOURCE=$(ROOT)\generic\threadSvListCmd.c # End Source File # Begin Source File SOURCE=$(ROOT)\generic\threadSvListCmd.h # End Source File # End Group # Begin Group "doc" # PROP Default_Filter "" # Begin Group "html" # PROP Default_Filter "" # Begin Source File SOURCE=$(ROOT)\doc\html\thread.html # End Source File # Begin Source File SOURCE=$(ROOT)\doc\html\tpool.html # End Source File # Begin Source File SOURCE=$(ROOT)\doc\html\tsv.html # End Source File # Begin Source File SOURCE=$(ROOT)\doc\html\ttrace.html # End Source File # End Group # Begin Group "man" # PROP Default_Filter "" # Begin Source File SOURCE=$(ROOT)\doc\man\thread.n # End Source File # Begin Source File SOURCE=$(ROOT)\doc\man\tpool.n # End Source File # Begin Source File SOURCE=$(ROOT)\doc\man\tsv.n # End Source File # Begin Source File SOURCE=$(ROOT)\doc\man\ttrace.n # End Source File # End Group # Begin Source File SOURCE=$(ROOT)\doc\format.tcl # End Source File # Begin Source File SOURCE=$(ROOT)\doc\man.macros # End Source File # Begin Source File SOURCE=$(ROOT)\doc\thread.man # End Source File # Begin Source File SOURCE=$(ROOT)\doc\tpool.man # End Source File # Begin Source File SOURCE=$(ROOT)\doc\tsv.man # End Source File # Begin Source File SOURCE=$(ROOT)\doc\ttrace.man # End Source File # End Group # Begin Group "win" # PROP Default_Filter "" # Begin Group "vc" # PROP Default_Filter "" # Begin Source File SOURCE=.\makefile.vc # End Source File # Begin Source File SOURCE=.\nmakehlp.c # End Source File # Begin Source File SOURCE=.\pkg.vc # End Source File # Begin Source File SOURCE=.\README.vc.txt # End Source File # Begin Source File SOURCE=.\rules.vc # End Source File # End Group # Begin Source File SOURCE=$(ROOT)\win\README.txt # End Source File # Begin Source File SOURCE=$(ROOT)\win\thread.rc # End Source File # End Group # Begin Source File SOURCE=$(ROOT)\ChangeLog # End Source File # Begin Source File SOURCE=$(ROOT)\license.terms # End Source File # Begin Source File SOURCE=$(ROOT)\README # End Source File # End Target # End Project thread3.0.1/win/thread_win.dsw0000644003604700454610000000102714726633451014753 0ustar dgp771divMicrosoft Developer Studio Workspace File, Format Version 6.00 # WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE! ############################################################################### Project: "thread"=.\thread.dsp - Package Owner=<4> Package=<5> {{{ }}} Package=<4> {{{ }}} ############################################################################### Global: Package=<5> {{{ }}} Package=<3> {{{ }}} ############################################################################### thread3.0.1/win/nmakehlp.c0000644003604700454610000005115514726633451014062 0ustar dgp771div/* * ---------------------------------------------------------------------------- * nmakehlp.c -- * * This is used to fix limitations within nmake and the environment. * * Copyright (c) 2002 David Gravereaux. * Copyright (c) 2006 Pat Thoyts * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * ---------------------------------------------------------------------------- */ #define _CRT_SECURE_NO_DEPRECATE #include #ifdef _MSC_VER #pragma comment (lib, "user32.lib") #pragma comment (lib, "kernel32.lib") #endif #include /* * This library is required for x64 builds with _some_ versions of MSVC */ #if defined(_M_IA64) || defined(_M_AMD64) #if _MSC_VER >= 1400 && _MSC_VER < 1500 #pragma comment(lib, "bufferoverflowU") #endif #endif /* ISO hack for dumb VC++ */ #if defined(_WIN32) && defined(_MSC_VER) && _MSC_VER < 1900 #define snprintf _snprintf #endif /* protos */ static int CheckForCompilerFeature(const char *option); static int CheckForLinkerFeature(char **options, int count); static int IsIn(const char *string, const char *substring); static int SubstituteFile(const char *substs, const char *filename); static int QualifyPath(const char *path); static int LocateDependency(const char *keyfile); static const char *GetVersionFromFile(const char *filename, const char *match, int numdots); static DWORD WINAPI ReadFromPipe(LPVOID args); /* globals */ #define CHUNK 25 #define STATICBUFFERSIZE 1000 typedef struct { HANDLE pipe; char buffer[STATICBUFFERSIZE]; } pipeinfo; pipeinfo Out = {INVALID_HANDLE_VALUE, ""}; pipeinfo Err = {INVALID_HANDLE_VALUE, ""}; /* * exitcodes: 0 == no, 1 == yes, 2 == error */ int main( int argc, char *argv[]) { char msg[300]; DWORD dwWritten; int chars; const char *s; /* * Make sure children (cl.exe and link.exe) are kept quiet. */ SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOOPENFILEERRORBOX); /* * Make sure the compiler and linker aren't effected by the outside world. */ SetEnvironmentVariable("CL", ""); SetEnvironmentVariable("LINK", ""); if (argc > 1 && *argv[1] == '-') { switch (*(argv[1]+1)) { case 'c': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -c \n" "Tests for whether cl.exe supports an option\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return CheckForCompilerFeature(argv[2]); case 'l': if (argc < 3) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -l ? ...?\n" "Tests for whether link.exe supports an option\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return CheckForLinkerFeature(&argv[2], argc-2); case 'f': if (argc == 2) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -f \n" "Find a substring within another\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } else if (argc == 3) { /* * If the string is blank, there is no match. */ return 0; } else { return IsIn(argv[2], argv[3]); } case 's': if (argc == 2) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -s \n" "Perform a set of string map type substutitions on a file\n" "exitcodes: 0\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return SubstituteFile(argv[2], argv[3]); case 'V': if (argc != 4) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -V filename matchstring\n" "Extract a version from a file:\n" "eg: pkgIndex.tcl \"package ifneeded http\"", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 0; } s = GetVersionFromFile(argv[2], argv[3], *(argv[1]+2) - '0'); if (s && *s) { printf("%s\n", s); return 0; } else return 1; /* Version not found. Return non-0 exit code */ case 'Q': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -Q path\n" "Emit the fully qualified path\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return QualifyPath(argv[2]); case 'L': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -L keypath\n" "Emit the fully qualified path of directory containing keypath\n" "exitcodes: 0 == success, 1 == not found, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return LocateDependency(argv[2]); } } chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -c|-f|-l|-Q|-s|-V ...\n" "This is a little helper app to equalize shell differences between WinNT and\n" "Win9x and get nmake.exe to accomplish its job.\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } static int CheckForCompilerFeature( const char *option) { STARTUPINFO si; PROCESS_INFORMATION pi; SECURITY_ATTRIBUTES sa; DWORD threadID; char msg[300]; BOOL ok; HANDLE hProcess, h, pipeThreads[2]; char cmdline[100]; hProcess = GetCurrentProcess(); memset(&pi, 0, sizeof(PROCESS_INFORMATION)); memset(&si, 0, sizeof(STARTUPINFO)); si.cb = sizeof(STARTUPINFO); si.dwFlags = STARTF_USESTDHANDLES; si.hStdInput = INVALID_HANDLE_VALUE; memset(&sa, 0, sizeof(SECURITY_ATTRIBUTES)); sa.nLength = sizeof(SECURITY_ATTRIBUTES); sa.lpSecurityDescriptor = NULL; sa.bInheritHandle = FALSE; /* * Create a non-inheritable pipe. */ CreatePipe(&Out.pipe, &h, &sa, 0); /* * Dupe the write side, make it inheritable, and close the original. */ DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); /* * Same as above, but for the error side. */ CreatePipe(&Err.pipe, &h, &sa, 0); DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); /* * Base command line. */ lstrcpy(cmdline, "cl.exe -nologo -c -TC -Zs -X -Fp.\\_junk.pch "); /* * Append our option for testing */ lstrcat(cmdline, option); /* * Filename to compile, which exists, but is nothing and empty. */ lstrcat(cmdline, " .\\nul"); ok = CreateProcess( NULL, /* Module name. */ cmdline, /* Command line. */ NULL, /* Process handle not inheritable. */ NULL, /* Thread handle not inheritable. */ TRUE, /* yes, inherit handles. */ DETACHED_PROCESS, /* No console for you. */ NULL, /* Use parent's environment block. */ NULL, /* Use parent's starting directory. */ &si, /* Pointer to STARTUPINFO structure. */ &pi); /* Pointer to PROCESS_INFORMATION structure. */ if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars], (300-chars), 0); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL); return 2; } /* * Close our references to the write handles that have now been inherited. */ CloseHandle(si.hStdOutput); CloseHandle(si.hStdError); WaitForInputIdle(pi.hProcess, 5000); CloseHandle(pi.hThread); /* * Start the pipe reader threads. */ pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID); pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID); /* * Block waiting for the process to end. */ WaitForSingleObject(pi.hProcess, INFINITE); CloseHandle(pi.hProcess); /* * Wait for our pipe to get done reading, should it be a little slow. */ WaitForMultipleObjects(2, pipeThreads, TRUE, 500); CloseHandle(pipeThreads[0]); CloseHandle(pipeThreads[1]); /* * Look for the commandline warning code in both streams. * - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002. */ return !(strstr(Out.buffer, "D4002") != NULL || strstr(Err.buffer, "D4002") != NULL || strstr(Out.buffer, "D9002") != NULL || strstr(Err.buffer, "D9002") != NULL || strstr(Out.buffer, "D2021") != NULL || strstr(Err.buffer, "D2021") != NULL); } static int CheckForLinkerFeature( char **options, int count) { STARTUPINFO si; PROCESS_INFORMATION pi; SECURITY_ATTRIBUTES sa; DWORD threadID; char msg[300]; BOOL ok; HANDLE hProcess, h, pipeThreads[2]; int i; char cmdline[255]; hProcess = GetCurrentProcess(); memset(&pi, 0, sizeof(PROCESS_INFORMATION)); memset(&si, 0, sizeof(STARTUPINFO)); si.cb = sizeof(STARTUPINFO); si.dwFlags = STARTF_USESTDHANDLES; si.hStdInput = INVALID_HANDLE_VALUE; memset(&sa, 0, sizeof(SECURITY_ATTRIBUTES)); sa.nLength = sizeof(SECURITY_ATTRIBUTES); sa.lpSecurityDescriptor = NULL; sa.bInheritHandle = TRUE; /* * Create a non-inheritible pipe. */ CreatePipe(&Out.pipe, &h, &sa, 0); /* * Dupe the write side, make it inheritable, and close the original. */ DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); /* * Same as above, but for the error side. */ CreatePipe(&Err.pipe, &h, &sa, 0); DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); /* * Base command line. */ lstrcpy(cmdline, "link.exe -nologo "); /* * Append our option for testing. */ for (i = 0; i < count; i++) { lstrcat(cmdline, " \""); lstrcat(cmdline, options[i]); lstrcat(cmdline, "\""); } ok = CreateProcess( NULL, /* Module name. */ cmdline, /* Command line. */ NULL, /* Process handle not inheritable. */ NULL, /* Thread handle not inheritable. */ TRUE, /* yes, inherit handles. */ DETACHED_PROCESS, /* No console for you. */ NULL, /* Use parent's environment block. */ NULL, /* Use parent's starting directory. */ &si, /* Pointer to STARTUPINFO structure. */ &pi); /* Pointer to PROCESS_INFORMATION structure. */ if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars], (300-chars), 0); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL); return 2; } /* * Close our references to the write handles that have now been inherited. */ CloseHandle(si.hStdOutput); CloseHandle(si.hStdError); WaitForInputIdle(pi.hProcess, 5000); CloseHandle(pi.hThread); /* * Start the pipe reader threads. */ pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID); pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID); /* * Block waiting for the process to end. */ WaitForSingleObject(pi.hProcess, INFINITE); CloseHandle(pi.hProcess); /* * Wait for our pipe to get done reading, should it be a little slow. */ WaitForMultipleObjects(2, pipeThreads, TRUE, 500); CloseHandle(pipeThreads[0]); CloseHandle(pipeThreads[1]); /* * Look for the commandline warning code in the stderr stream. */ return !(strstr(Out.buffer, "LNK1117") != NULL || strstr(Err.buffer, "LNK1117") != NULL || strstr(Out.buffer, "LNK4044") != NULL || strstr(Err.buffer, "LNK4044") != NULL || strstr(Out.buffer, "LNK4224") != NULL || strstr(Err.buffer, "LNK4224") != NULL); } static DWORD WINAPI ReadFromPipe( LPVOID args) { pipeinfo *pi = (pipeinfo *) args; char *lastBuf = pi->buffer; DWORD dwRead; BOOL ok; again: if (lastBuf - pi->buffer + CHUNK > STATICBUFFERSIZE) { CloseHandle(pi->pipe); return (DWORD)-1; } ok = ReadFile(pi->pipe, lastBuf, CHUNK, &dwRead, 0L); if (!ok || dwRead == 0) { CloseHandle(pi->pipe); return 0; } lastBuf += dwRead; goto again; return 0; /* makes the compiler happy */ } static int IsIn( const char *string, const char *substring) { return (strstr(string, substring) != NULL); } /* * GetVersionFromFile -- * Looks for a match string in a file and then returns the version * following the match where a version is anything acceptable to * package provide or package ifneeded. */ static const char * GetVersionFromFile( const char *filename, const char *match, int numdots) { static char szBuffer[100]; char *szResult = NULL; FILE *fp = fopen(filename, "rt"); if (fp != NULL) { /* * Read data until we see our match string. */ while (fgets(szBuffer, sizeof(szBuffer), fp) != NULL) { LPSTR p, q; p = strstr(szBuffer, match); if (p != NULL) { /* * Skip to first digit after the match. */ p += strlen(match); while (*p && !isdigit((unsigned char)*p)) { ++p; } /* * Find ending whitespace. */ q = p; while (*q && (strchr("0123456789.ab", *q)) && (((!strchr(".ab", *q) && !strchr("ab", q[-1])) || --numdots))) { ++q; } *q = 0; szResult = p; break; } } fclose(fp); } return szResult; } /* * List helpers for the SubstituteFile function */ typedef struct list_item_t { struct list_item_t *nextPtr; char * key; char * value; } list_item_t; /* insert a list item into the list (list may be null) */ static list_item_t * list_insert(list_item_t **listPtrPtr, const char *key, const char *value) { list_item_t *itemPtr = (list_item_t *)malloc(sizeof(list_item_t)); if (itemPtr) { itemPtr->key = strdup(key); itemPtr->value = strdup(value); itemPtr->nextPtr = NULL; while(*listPtrPtr) { listPtrPtr = &(*listPtrPtr)->nextPtr; } *listPtrPtr = itemPtr; } return itemPtr; } static void list_free(list_item_t **listPtrPtr) { list_item_t *tmpPtr, *listPtr = *listPtrPtr; while (listPtr) { tmpPtr = listPtr; listPtr = listPtr->nextPtr; free(tmpPtr->key); free(tmpPtr->value); free(tmpPtr); } } /* * SubstituteFile -- * As windows doesn't provide anything useful like sed and it's unreliable * to use the tclsh you are building against (consider x-platform builds - * e.g. compiling AMD64 target from IX86) we provide a simple substitution * option here to handle autoconf style substitutions. * The substitution file is whitespace and line delimited. The file should * consist of lines matching the regular expression: * \s*\S+\s+\S*$ * * Usage is something like: * nmakehlp -S << $** > $@ * @PACKAGE_NAME@ $(PACKAGE_NAME) * @PACKAGE_VERSION@ $(PACKAGE_VERSION) * << */ static int SubstituteFile( const char *substitutions, const char *filename) { static char szBuffer[1024], szCopy[1024]; list_item_t *substPtr = NULL; FILE *fp, *sp; fp = fopen(filename, "rt"); if (fp != NULL) { /* * Build a list of substitutions from the first filename */ sp = fopen(substitutions, "rt"); if (sp != NULL) { while (fgets(szBuffer, sizeof(szBuffer), sp) != NULL) { unsigned char *ks, *ke, *vs, *ve; ks = (unsigned char*)szBuffer; while (ks && *ks && isspace(*ks)) ++ks; ke = ks; while (ke && *ke && !isspace(*ke)) ++ke; vs = ke; while (vs && *vs && isspace(*vs)) ++vs; ve = vs; while (ve && *ve && !(*ve == '\r' || *ve == '\n')) ++ve; *ke = 0, *ve = 0; list_insert(&substPtr, (char*)ks, (char*)vs); } fclose(sp); } /* debug: dump the list */ #ifndef NDEBUG { int n = 0; list_item_t *p = NULL; for (p = substPtr; p != NULL; p = p->nextPtr, ++n) { fprintf(stderr, "% 3d '%s' => '%s'\n", n, p->key, p->value); } } #endif /* * Run the substitutions over each line of the input */ while (fgets(szBuffer, sizeof(szBuffer), fp) != NULL) { list_item_t *p = NULL; for (p = substPtr; p != NULL; p = p->nextPtr) { char *m = strstr(szBuffer, p->key); if (m) { char *cp, *op, *sp; cp = szCopy; op = szBuffer; while (op != m) *cp++ = *op++; sp = p->value; while (sp && *sp) *cp++ = *sp++; op += strlen(p->key); while (*op) *cp++ = *op++; *cp = 0; memcpy(szBuffer, szCopy, sizeof(szCopy)); } } printf("%s", szBuffer); } list_free(&substPtr); } fclose(fp); return 0; } BOOL FileExists(LPCTSTR szPath) { #ifndef INVALID_FILE_ATTRIBUTES #define INVALID_FILE_ATTRIBUTES ((DWORD)-1) #endif DWORD pathAttr = GetFileAttributes(szPath); return (pathAttr != INVALID_FILE_ATTRIBUTES && !(pathAttr & FILE_ATTRIBUTE_DIRECTORY)); } /* * QualifyPath -- * * This composes the current working directory with a provided path * and returns the fully qualified and normalized path. * Mostly needed to setup paths for testing. */ static int QualifyPath( const char *szPath) { char szCwd[MAX_PATH + 1]; GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL); printf("%s\n", szCwd); return 0; } /* * Implements LocateDependency for a single directory. See that command * for an explanation. * Returns 0 if found after printing the directory. * Returns 1 if not found but no errors. * Returns 2 on any kind of error * Basically, these are used as exit codes for the process. */ static int LocateDependencyHelper(const char *dir, const char *keypath) { HANDLE hSearch; char path[MAX_PATH+1]; size_t dirlen; int keylen, ret; WIN32_FIND_DATA finfo; if (dir == NULL || keypath == NULL) { return 2; /* Have no real error reporting mechanism into nmake */ } dirlen = strlen(dir); if (dirlen > sizeof(path) - 3) { return 2; } strncpy(path, dir, dirlen); strncpy(path+dirlen, "\\*", 3); /* Including terminating \0 */ keylen = strlen(keypath); #if 0 /* This function is not available in Visual C++ 6 */ /* * Use numerics 0 -> FindExInfoStandard, * 1 -> FindExSearchLimitToDirectories, * as these are not defined in Visual C++ 6 */ hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0); #else hSearch = FindFirstFile(path, &finfo); #endif if (hSearch == INVALID_HANDLE_VALUE) { return 1; /* Not found */ } /* Loop through all subdirs checking if the keypath is under there */ ret = 1; /* Assume not found */ do { int sublen; /* * We need to check it is a directory despite the * FindExSearchLimitToDirectories in the above call. See SDK docs */ if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) { continue; } sublen = strlen(finfo.cFileName); if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) { continue; /* Path does not fit, assume not matched */ } strncpy(path+dirlen+1, finfo.cFileName, sublen); path[dirlen+1+sublen] = '\\'; strncpy(path+dirlen+1+sublen+1, keypath, keylen+1); if (FileExists(path)) { /* Found a match, print to stdout */ path[dirlen+1+sublen] = '\0'; QualifyPath(path); ret = 0; break; } } while (FindNextFile(hSearch, &finfo)); FindClose(hSearch); return ret; } /* * LocateDependency -- * * Locates a dependency for a package. * keypath - a relative path within the package directory * that is used to confirm it is the correct directory. * The search path for the package directory is currently only * the parent and grandparent of the current working directory. * If found, the command prints * name_DIRPATH= * and returns 0. If not found, does not print anything and returns 1. */ static int LocateDependency(const char *keypath) { size_t i; int ret; static const char *paths[] = {"..", "..\\..", "..\\..\\.."}; for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) { ret = LocateDependencyHelper(paths[i], keypath); if (ret == 0) { return ret; } } return ret; } /* * Local variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * indent-tabs-mode: t * tab-width: 8 * End: */ thread3.0.1/win/threadUuid.h.in0000644003604700454610000000003614726633451014763 0ustar dgp771div#define THREAD_VERSION_UUID \ thread3.0.1/win/svnmanifest.in0000644003604700454610000000000514726633451014770 0ustar dgp771divsvn-rthread3.0.1/win/gitmanifest.in0000644003604700454610000000000414726633451014744 0ustar dgp771divgit-thread3.0.1/win/targets.vc0000644003604700454610000000505614726633451014121 0ustar dgp771div#------------------------------------------------------------- -*- makefile -*- # targets.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file defines some standard targets for the convenience of extensions # and can be optionally included by the extension makefile. # See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for docs. $(PROJECT): setup pkgindex $(PRJLIB) !ifdef PRJ_STUBOBJS $(PROJECT): $(PRJSTUBLIB) $(PRJSTUBLIB): $(PRJ_STUBOBJS) $(LIBCMD) $** $(PRJ_STUBOBJS): $(CCSTUBSCMD) %s !endif # PRJ_STUBOBJS !ifdef PRJ_MANIFEST $(PROJECT): $(PRJLIB).manifest $(PRJLIB).manifest: $(PRJ_MANIFEST) @nmakehlp -s << $** >$@ @MACHINE@ $(MACHINE:IX86=X86) << !endif !if "$(PROJECT)" != "tcl" && "$(PROJECT)" != "tk" $(PRJLIB): $(PRJ_OBJS) $(RESFILE) !if $(STATIC_BUILD) $(LIBCMD) $** !else $(DLLCMD) $** $(_VC_MANIFEST_EMBED_DLL) !endif -@del $*.exp !endif !if "$(PRJ_HEADERS)" != "" && "$(PRJ_OBJS)" != "" $(PRJ_OBJS): $(PRJ_HEADERS) !endif # If parent makefile has defined stub objects, add their installation # to the default install !if "$(PRJ_STUBOBJS)" != "" default-install: default-install-stubs !endif # Unlike the other default targets, these cannot be in rules.vc because # the executed command depends on existence of macro PRJ_HEADERS_PUBLIC # that the parent makefile will not define until after including rules-ext.vc !if "$(PRJ_HEADERS_PUBLIC)" != "" default-install: default-install-headers default-install-headers: @echo Installing headers to '$(INCLUDE_INSTALL_DIR)' @for %f in ($(PRJ_HEADERS_PUBLIC)) do @$(COPY) %f "$(INCLUDE_INSTALL_DIR)" !endif !if "$(DISABLE_STANDARD_TARGETS)" == "" DISABLE_STANDARD_TARGETS = 0 !endif !if "$(DISABLE_TARGET_setup)" == "" DISABLE_TARGET_setup = 0 !endif !if "$(DISABLE_TARGET_install)" == "" DISABLE_TARGET_install = 0 !endif !if "$(DISABLE_TARGET_clean)" == "" DISABLE_TARGET_clean = 0 !endif !if "$(DISABLE_TARGET_test)" == "" DISABLE_TARGET_test = 0 !endif !if "$(DISABLE_TARGET_shell)" == "" DISABLE_TARGET_shell = 0 !endif !if !$(DISABLE_STANDARD_TARGETS) !if !$(DISABLE_TARGET_setup) setup: default-setup !endif !if !$(DISABLE_TARGET_install) install: default-install !endif !if !$(DISABLE_TARGET_clean) clean: default-clean realclean: hose hose: default-hose distclean: realclean default-distclean !endif !if !$(DISABLE_TARGET_test) test: default-test !endif !if !$(DISABLE_TARGET_shell) shell: default-shell !endif !endif # DISABLE_STANDARD_TARGETS thread3.0.1/win/rules.vc0000644003604700454610000017411214726633451013602 0ustar dgp771div#------------------------------------------------------------- -*- makefile -*- # rules.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file does all the hard work in terms of parsing build options, # compiler switches, defining common targets and macros. The Tcl makefile # directly includes this. Extensions include it via "rules-ext.vc". # # See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for # detailed documentation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2001-2003 David Gravereaux. # Copyright (c) 2003-2008 Patrick Thoyts # Copyright (c) 2017 Ashok P. Nadkarni #------------------------------------------------------------------------------ !ifndef _RULES_VC _RULES_VC = 1 # The following macros define the version of the rules.vc nmake build system # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 RULES_VERSION_MINOR = 13 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" !error *** Error: Macro PROJECT not defined! Please define it before including rules.vc !endif !if "$(PRJ_PACKAGE_TCLNAME)" == "" PRJ_PACKAGE_TCLNAME = $(PROJECT) !endif # Also special case Tcl and Tk to save some typing later DOING_TCL = 0 DOING_TK = 0 !if "$(PROJECT)" == "tcl" DOING_TCL = 1 !elseif "$(PROJECT)" == "tk" DOING_TK = 1 !endif !ifndef NEED_TK # Backwards compatibility !ifdef PROJECT_REQUIRES_TK NEED_TK = $(PROJECT_REQUIRES_TK) !else NEED_TK = 0 !endif !endif !ifndef NEED_TCL_SOURCE NEED_TCL_SOURCE = 0 !endif !ifdef NEED_TK_SOURCE !if $(NEED_TK_SOURCE) NEED_TK = 1 !endif !else NEED_TK_SOURCE = 0 !endif ################################################################ # Nmake is a pretty weak environment in syntax and capabilities # so this file is necessarily verbose. It's broken down into # the following parts. # # 0. Sanity check that compiler environment is set up and initialize # any built-in settings from the parent makefile # 1. First define the external tools used for compiling, copying etc. # as this is independent of everything else. # 2. Figure out our build structure in terms of the directory, whether # we are building Tcl or an extension, etc. # 3. Determine the compiler and linker versions # 4. Build the nmakehlp helper application # 5. Determine the supported compiler options and features # 6. Extract Tcl, Tk, and possibly extensions, version numbers from the # headers # 7. Parse the OPTS macro value for user-specified build configuration # 8. Parse the STATS macro value for statistics instrumentation # 9. Parse the CHECKS macro for additional compilation checks # 10. Based on this selected configuration, construct the output # directory and file paths # 11. Construct the paths where the package is to be installed # 12. Set up the actual options passed to compiler and linker based # on the information gathered above. # 13. Define some standard build targets and implicit rules. These may # be optionally disabled by the parent makefile. # 14. (For extensions only.) Compare the configuration of the target # Tcl and the extensions and warn against discrepancies. # # One final note about the macro names used. They are as they are # for historical reasons. We would like legacy extensions to # continue to work with this make include file so be wary of # changing them for consistency or clarity. # 0. Sanity check compiler environment # Check to see we are configured to build with MSVC (MSDEVDIR, MSVCDIR or # VCINSTALLDIR) or with the MS Platform SDK (MSSDK or WindowsSDKDir) !if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCINSTALLDIR) && !defined(MSSDK) && !defined(WINDOWSSDKDIR) MSG = ^ Visual C++ compiler environment not initialized. !error $(MSG) !endif # We need to run from the directory the parent makefile is located in. # nmake does not tell us what makefile was used to invoke it so parent # makefile has to set the MAKEFILEVC macro or we just make a guess and # warn if we think that is not the case. !if "$(MAKEFILEVC)" == "" !if exist("$(PROJECT).vc") MAKEFILEVC = $(PROJECT).vc !elseif exist("makefile.vc") MAKEFILEVC = makefile.vc !endif !endif # "$(MAKEFILEVC)" == "" !if !exist("$(MAKEFILEVC)") MSG = ^ You must run nmake from the directory containing the project makefile.^ If you are doing that and getting this message, set the MAKEFILEVC^ macro to the name of the project makefile. !message WARNING: $(MSG) !endif ################################################################ # 1. Define external programs being used #---------------------------------------------------------- # Set the proper copy method to avoid overwrite questions # to the user when copying files and selecting the right # "delete all" method. #---------------------------------------------------------- RMDIR = rmdir /S /Q CPY = xcopy /i /y >NUL CPYDIR = xcopy /e /i /y >NUL COPY = copy /y >NUL MKDIR = mkdir ###################################################################### # 2. Figure out our build environment in terms of what we're building. # # (a) Tcl itself # (b) Tk # (c) a Tcl extension using libraries/includes from an *installed* Tcl # (d) a Tcl extension using libraries/includes from Tcl source directory # # This last is needed because some extensions still need # some Tcl interfaces that are not publicly exposed. # # The fragment will set the following macros: # ROOT - root of this module sources # COMPATDIR - source directory that holds compatibility sources # DOCDIR - source directory containing documentation files # GENERICDIR - platform-independent source directory # WIN_DIR - Windows-specific source directory # TESTDIR - directory containing test files # TOOLSDIR - directory containing build tools # _TCLDIR - root of the Tcl installation OR the Tcl sources. Not set # when building Tcl itself. # _INSTALLDIR - native form of the installation path. For Tcl # this will be the root of the Tcl installation. For extensions # this will be the lib directory under the root. # TCLINSTALL - set to 1 if _TCLDIR refers to # headers and libraries from an installed Tcl, and 0 if built against # Tcl sources. Not set when building Tcl itself. Yes, not very well # named. # _TCL_H - native path to the tcl.h file # # If Tk is involved, also sets the following # _TKDIR - native form Tk installation OR Tk source. Not set if building # Tk itself. # TKINSTALL - set 1 if _TKDIR refers to installed Tk and 0 if Tk sources # _TK_H - native path to the tk.h file # Root directory for sources and assumed subdirectories ROOT = $(MAKEDIR)\.. # The following paths CANNOT have spaces in them as they appear on the # left side of implicit rules. !ifndef COMPATDIR COMPATDIR = $(ROOT)\compat !endif !ifndef DOCDIR DOCDIR = $(ROOT)\doc !endif !ifndef GENERICDIR GENERICDIR = $(ROOT)\generic !endif !ifndef TOOLSDIR TOOLSDIR = $(ROOT)\tools !endif !ifndef TESTDIR TESTDIR = $(ROOT)\tests !endif !ifndef LIBDIR !if exist("$(ROOT)\library") LIBDIR = $(ROOT)\library !else LIBDIR = $(ROOT)\lib !endif !endif !ifndef DEMODIR !if exist("$(LIBDIR)\demos") DEMODIR = $(LIBDIR)\demos !else DEMODIR = $(ROOT)\demos !endif !endif # ifndef DEMODIR # Do NOT use WINDIR because it is Windows internal environment # variable to point to c:\windows! WIN_DIR = $(ROOT)\win !ifndef RCDIR !if exist("$(WIN_DIR)\rc") RCDIR = $(WIN_DIR)\rc !else RCDIR = $(WIN_DIR) !endif !endif RCDIR = $(RCDIR:/=\) # The target directory where the built packages and binaries will be installed. # INSTALLDIR is the (optional) path specified by the user. # _INSTALLDIR is INSTALLDIR using the backslash separator syntax !ifdef INSTALLDIR ### Fix the path separators. _INSTALLDIR = $(INSTALLDIR:/=\) !else ### Assume the normal default. _INSTALLDIR = $(HOMEDRIVE)\Tcl !endif !if $(DOING_TCL) # BEGIN Case 2(a) - Building Tcl itself # Only need to define _TCL_H _TCL_H = ..\generic\tcl.h # END Case 2(a) - Building Tcl itself !elseif $(DOING_TK) # BEGIN Case 2(b) - Building Tk TCLINSTALL = 0 # Tk always builds against Tcl source, not an installed Tcl !if "$(TCLDIR)" == "" !if [echo TCLDIR = \> nmakehlp.out] \ || [nmakehlp -L generic\tcl.h >> nmakehlp.out] !error *** Could not locate Tcl source directory. !endif !include nmakehlp.out !endif # TCLDIR == "" _TCLDIR = $(TCLDIR:/=\) _TCL_H = $(_TCLDIR)\generic\tcl.h !if !exist("$(_TCL_H)") !error Could not locate tcl.h. Please set the TCLDIR macro to point to the Tcl *source* directory. !endif _TK_H = ..\generic\tk.h # END Case 2(b) - Building Tk !else # BEGIN Case 2(c) or (d) - Building an extension other than Tk # If command line has specified Tcl location through TCLDIR, use it # else default to the INSTALLDIR setting !if "$(TCLDIR)" != "" _TCLDIR = $(TCLDIR:/=\) !if exist("$(_TCLDIR)\include\tcl.h") # Case 2(c) with TCLDIR defined TCLINSTALL = 1 _TCL_H = $(_TCLDIR)\include\tcl.h !elseif exist("$(_TCLDIR)\generic\tcl.h") # Case 2(d) with TCLDIR defined TCLINSTALL = 0 _TCL_H = $(_TCLDIR)\generic\tcl.h !endif !else # # Case 2(c) for extensions with TCLDIR undefined # Need to locate Tcl depending on whether it needs Tcl source or not. # If we don't, check the INSTALLDIR for an installed Tcl first !if exist("$(_INSTALLDIR)\include\tcl.h") && !$(NEED_TCL_SOURCE) TCLINSTALL = 1 TCLDIR = $(_INSTALLDIR)\.. # NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions # later so the \.. accounts for the /lib _TCLDIR = $(_INSTALLDIR)\.. _TCL_H = $(_TCLDIR)\include\tcl.h !else # exist(...) && !$(NEED_TCL_SOURCE) !if [echo _TCLDIR = \> nmakehlp.out] \ || [nmakehlp -L generic\tcl.h >> nmakehlp.out] !error *** Could not locate Tcl source directory. !endif !include nmakehlp.out TCLINSTALL = 0 TCLDIR = $(_TCLDIR) _TCL_H = $(_TCLDIR)\generic\tcl.h !endif # exist(...) && !$(NEED_TCL_SOURCE) !endif # TCLDIR !ifndef _TCL_H MSG =^ Failed to find tcl.h. The TCLDIR macro is set incorrectly or is not set and default path does not contain tcl.h. !error $(MSG) !endif # Now do the same to locate Tk headers and libs if project requires Tk !if $(NEED_TK) !if "$(TKDIR)" != "" _TKDIR = $(TKDIR:/=\) !if exist("$(_TKDIR)\include\tk.h") TKINSTALL = 1 _TK_H = $(_TKDIR)\include\tk.h !elseif exist("$(_TKDIR)\generic\tk.h") TKINSTALL = 0 _TK_H = $(_TKDIR)\generic\tk.h !endif !else # TKDIR not defined # Need to locate Tcl depending on whether it needs Tcl source or not. # If we don't, check the INSTALLDIR for an installed Tcl first !if exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE) TKINSTALL = 1 # NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions # later so the \.. accounts for the /lib _TKDIR = $(_INSTALLDIR)\.. _TK_H = $(_TKDIR)\include\tk.h TKDIR = $(_TKDIR) !else # exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE) !if [echo _TKDIR = \> nmakehlp.out] \ || [nmakehlp -L generic\tk.h >> nmakehlp.out] !error *** Could not locate Tk source directory. !endif !include nmakehlp.out TKINSTALL = 0 TKDIR = $(_TKDIR) _TK_H = $(_TKDIR)\generic\tk.h !endif # exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE) !endif # TKDIR !ifndef _TK_H MSG =^ Failed to find tk.h. The TKDIR macro is set incorrectly or is not set and default path does not contain tk.h. !error $(MSG) !endif !endif # NEED_TK !if $(NEED_TCL_SOURCE) && $(TCLINSTALL) MSG = ^ *** Warning: This extension requires the source distribution of Tcl.^ *** Please set the TCLDIR macro to point to the Tcl sources. !error $(MSG) !endif !if $(NEED_TK_SOURCE) !if $(TKINSTALL) MSG = ^ *** Warning: This extension requires the source distribution of Tk.^ *** Please set the TKDIR macro to point to the Tk sources. !error $(MSG) !endif !endif # If INSTALLDIR set to Tcl installation root dir then reset to the # lib dir for installing extensions !if exist("$(_INSTALLDIR)\include\tcl.h") _INSTALLDIR=$(_INSTALLDIR)\lib !endif # END Case 2(c) or (d) - Building an extension !endif # if $(DOING_TCL) ################################################################ # 3. Determine compiler version and architecture # In this section, we figure out the compiler version and the # architecture for which we are building. This sets the # following macros: # VCVERSION - the internal compiler version as 1200, 1400, 1910 etc. # This is also printed by the compiler in dotted form 19.10 etc. # VCVER - the "marketing version", for example Visual C++ 6 for internal # compiler version 1200. This is kept only for legacy reasons as it # does not make sense for recent Microsoft compilers. Only used for # output directory names. # ARCH - set to IX86, ARM64 or AMD64 depending on 32- or 64-bit target # NATIVE_ARCH - set to IX86, ARM64 or AMD64 for the host machine # MACHINE - same as $(ARCH) - legacy # _VC_MANIFEST_EMBED_{DLL,EXE} - commands for embedding a manifest if needed cc32 = $(CC) # built-in default. link32 = link lib32 = lib rc32 = $(RC) # built-in default. #---------------------------------------------------------------- # Figure out the compiler architecture and version by writing # the C macros to a file, preprocessing them with the C # preprocessor and reading back the created file _HASH=^# _VC_MANIFEST_EMBED_EXE= _VC_MANIFEST_EMBED_DLL= VCVER=0 !if ![echo VCVERSION=_MSC_VER > vercl.x] \ && ![echo $(_HASH)if defined(_M_IX86) >> vercl.x] \ && ![echo ARCH=IX86 >> vercl.x] \ && ![echo $(_HASH)elif defined(_M_AMD64) >> vercl.x] \ && ![echo ARCH=AMD64 >> vercl.x] \ && ![echo $(_HASH)elif defined(_M_ARM64) >> vercl.x] \ && ![echo ARCH=ARM64 >> vercl.x] \ && ![echo $(_HASH)endif >> vercl.x] \ && ![$(cc32) -nologo -TC -P vercl.x 2>NUL] !include vercl.i !if $(VCVERSION) < 1900 !if ![echo VCVER= ^\> vercl.vc] \ && ![set /a $(VCVERSION) / 100 - 6 >> vercl.vc] !include vercl.vc !endif !else # The simple calculation above does not apply to new Visual Studio releases # Keep the compiler version in its native form. VCVER = $(VCVERSION) !endif !endif !if ![del 2>NUL /q/f vercl.x vercl.i vercl.vc] !endif #---------------------------------------------------------------- # The MACHINE macro is used by legacy makefiles so set it as well !ifdef MACHINE !if "$(MACHINE)" == "x86" !undef MACHINE MACHINE = IX86 !elseif "$(MACHINE)" == "arm64" !undef MACHINE MACHINE = ARM64 !elseif "$(MACHINE)" == "x64" !undef MACHINE MACHINE = AMD64 !endif !if "$(MACHINE)" != "$(ARCH)" !error Specified MACHINE macro $(MACHINE) does not match detected target architecture $(ARCH). !endif !else MACHINE=$(ARCH) !endif #--------------------------------------------------------------- # The PLATFORM_IDENTIFY macro matches the values returned by # the Tcl platform::identify command !if "$(MACHINE)" == "AMD64" PLATFORM_IDENTIFY = win32-x86_64 !elseif "$(MACHINE)" == "ARM64" PLATFORM_IDENTIFY = win32-arm !else PLATFORM_IDENTIFY = win32-ix86 !endif # The MULTIPLATFORM macro controls whether binary extensions are installed # in platform-specific directories. Intended to be set/used by extensions. !ifndef MULTIPLATFORM_INSTALL MULTIPLATFORM_INSTALL = 0 !endif #------------------------------------------------------------ # Figure out the *host* architecture by reading the registry !if ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i x86] NATIVE_ARCH=IX86 !elseif ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i ARM | findstr /i 64-bit] NATIVE_ARCH=ARM64 !else NATIVE_ARCH=AMD64 !endif # Since MSVC8 we must deal with manifest resources. !if $(VCVERSION) >= 1400 _VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 _VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 !endif ################################################################ # 4. Build the nmakehlp program # This is a helper app we need to overcome nmake's limiting # environment. We will call out to it to get various bits of # information about supported compiler options etc. # # Tcl itself will always use the nmakehlp.c program which is # in its own source. It will be kept updated there. # # Extensions built against an installed Tcl will use the installed # copy of Tcl's nmakehlp.c if there is one and their own version # otherwise. In the latter case, they would also be using their own # rules.vc. Note that older versions of Tcl do not install nmakehlp.c # or rules.vc. # # Extensions built against Tcl sources will use the one from the Tcl source. # # When building an extension using a sufficiently new version of Tcl, # rules-ext.vc will define NMAKEHLPC appropriately to point to the # copy of nmakehlp.c to be used. !ifndef NMAKEHLPC # Default to the one in the current directory (the extension's own nmakehlp.c) NMAKEHLPC = nmakehlp.c !if !$(DOING_TCL) !if $(TCLINSTALL) !if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c") NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c !endif !else # !$(TCLINSTALL) !if exist("$(_TCLDIR)\win\nmakehlp.c") NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c !endif !endif # $(TCLINSTALL) !endif # !$(DOING_TCL) !endif # NMAKEHLPC # We always build nmakehlp even if it exists since we do not know # what source it was built from. !if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" !if [$(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console > nul] !endif !else !if [copy $(NMAKEHLPC:nmakehlp.c=x86_64-w64-mingw32-nmakehlp.exe) nmakehlp.exe >NUL] !endif !endif ################################################################ # 5. Test for compiler features # Visual C++ compiler options have changed over the years. Check # which options are supported by the compiler in use. # # The following macros are set: # OPTIMIZATIONS - the compiler flags to be used for optimized builds # DEBUGFLAGS - the compiler flags to be used for debug builds # LINKERFLAGS - Flags passed to the linker # # Note that these are the compiler settings *available*, not those # that will be *used*. The latter depends on the OPTS macro settings # which we have not yet parsed. # # Also note that some of the flags in OPTIMIZATIONS are not really # related to optimization. They are placed there only for legacy reasons # as some extensions expect them to be included in that macro. # -Op improves float consistency. Note only needed for older compilers # Newer compilers do not need or support this option. !if [nmakehlp -c -Op] FPOPTS = -Op !endif # Strict floating point semantics - present in newer compilers in lieu of -Op !if [nmakehlp -c -fp:strict] FPOPTS = $(FPOPTS) -fp:strict !endif !if "$(MACHINE)" == "IX86" ### test for pentium errata !if [nmakehlp -c -QI0f] !message *** Compiler has 'Pentium 0x0f fix' FPOPTS = $(FPOPTS) -QI0f !else !message *** Compiler does not have 'Pentium 0x0f fix' !endif !endif ### test for optimizations # /O2 optimization includes /Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy as per # documentation. Note we do NOT want /Gs as that inserts a _chkstk # stack probe at *every* function entry, not just those with more than # a page of stack allocation resulting in a performance hit. However, # /O2 documentation is misleading as its stack probes are simply the # default page size locals allocation probes and not what is implied # by an explicit /Gs option. OPTIMIZATIONS = $(FPOPTS) !if [nmakehlp -c -O2] OPTIMIZING = 1 OPTIMIZATIONS = $(OPTIMIZATIONS) -O2 !else # Legacy, really. All modern compilers support this !message *** Compiler does not have 'Optimizations' OPTIMIZING = 0 !endif # Checks for buffer overflows in local arrays !if [nmakehlp -c -GS] OPTIMIZATIONS = $(OPTIMIZATIONS) -GS !endif # Link time optimization. Note that this option (potentially) makes # generated libraries only usable by the specific VC++ version that # created it. Requires /LTCG linker option !if [nmakehlp -c -GL] OPTIMIZATIONS = $(OPTIMIZATIONS) -GL CC_GL_OPT_ENABLED = 1 !else # In newer compilers -GL and -YX are incompatible. !if [nmakehlp -c -YX] OPTIMIZATIONS = $(OPTIMIZATIONS) -YX !endif !endif # [nmakehlp -c -GL] DEBUGFLAGS = $(FPOPTS) # Run time error checks. Not available or valid in a release, non-debug build # RTC is for modern compilers, -GZ is legacy !if [nmakehlp -c -RTC1] DEBUGFLAGS = $(DEBUGFLAGS) -RTC1 !elseif [nmakehlp -c -GZ] DEBUGFLAGS = $(DEBUGFLAGS) -GZ !endif #---------------------------------------------------------------- # Linker flags # LINKER_TESTFLAGS are for internal use when we call nmakehlp to test # if the linker supports a specific option. Without these flags link will # return "LNK1561: entry point must be defined" error compiling from VS-IDE: # They are not passed through to the actual application / extension # link rules. !ifndef LINKER_TESTFLAGS LINKER_TESTFLAGS = /DLL /NOENTRY /OUT:nmakehlp.out !endif LINKERFLAGS = # If compiler has enabled link time optimization, linker must too with -ltcg !ifdef CC_GL_OPT_ENABLED !if [nmakehlp -l -ltcg $(LINKER_TESTFLAGS)] LINKERFLAGS = $(LINKERFLAGS) -ltcg !endif !endif ################################################################ # 6. Extract various version numbers from headers # For Tcl and Tk, version numbers are extracted from tcl.h and tk.h # respectively. For extensions, versions are extracted from the # configure.in or configure.ac from the TEA configuration if it # exists, and unset otherwise. # Sets the following macros: # TCL_MAJOR_VERSION # TCL_MINOR_VERSION # TCL_RELEASE_SERIAL # TCL_PATCH_LEVEL # TCL_PATCH_LETTER # TCL_VERSION # TK_MAJOR_VERSION # TK_MINOR_VERSION # TK_RELEASE_SERIAL # TK_PATCH_LEVEL # TK_PATCH_LETTER # TK_VERSION # DOTVERSION - set as (for example) 2.5 # VERSION - set as (for example 25) #-------------------------------------------------------------- !if [echo REM = This file is generated from rules.vc > versions.vc] !endif !if [echo TCL_MAJOR_VERSION = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" "define TCL_MAJOR_VERSION" >> versions.vc] !endif !if [echo TCL_MINOR_VERSION = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc] !endif !if [echo TCL_RELEASE_SERIAL = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_RELEASE_SERIAL >> versions.vc] !endif !if [echo TCL_PATCH_LEVEL = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_PATCH_LEVEL >> versions.vc] !endif !if defined(_TK_H) !if [echo TK_MAJOR_VERSION = \>> versions.vc] \ && [nmakehlp -V $(_TK_H) "define TK_MAJOR_VERSION" >> versions.vc] !endif !if [echo TK_MINOR_VERSION = \>> versions.vc] \ && [nmakehlp -V $(_TK_H) TK_MINOR_VERSION >> versions.vc] !endif !if [echo TK_RELEASE_SERIAL = \>> versions.vc] \ && [nmakehlp -V "$(_TK_H)" TK_RELEASE_SERIAL >> versions.vc] !endif !if [echo TK_PATCH_LEVEL = \>> versions.vc] \ && [nmakehlp -V $(_TK_H) TK_PATCH_LEVEL >> versions.vc] !endif !endif # _TK_H !include versions.vc TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) TCL_DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) !if [nmakehlp -f $(TCL_PATCH_LEVEL) "a"] TCL_PATCH_LETTER = a !elseif [nmakehlp -f $(TCL_PATCH_LEVEL) "b"] TCL_PATCH_LETTER = b !else TCL_PATCH_LETTER = . !endif !if defined(_TK_H) TK_VERSION = $(TK_MAJOR_VERSION)$(TK_MINOR_VERSION) TK_DOTVERSION = $(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) !if [nmakehlp -f $(TK_PATCH_LEVEL) "a"] TK_PATCH_LETTER = a !elseif [nmakehlp -f $(TK_PATCH_LEVEL) "b"] TK_PATCH_LETTER = b !else TK_PATCH_LETTER = . !endif !endif # Set DOTVERSION and VERSION !if $(DOING_TCL) DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) VERSION = $(TCL_VERSION) !elseif $(DOING_TK) DOTVERSION = $(TK_DOTVERSION) VERSION = $(TK_VERSION) !else # Doing a non-Tk extension # If parent makefile has not defined DOTVERSION, try to get it from TEA # first from a configure.in file, and then from configure.ac !ifndef DOTVERSION !if [echo DOTVERSION = \> versions.vc] \ || [nmakehlp -V $(ROOT)\configure.in ^[$(PROJECT)^] >> versions.vc] !if [echo DOTVERSION = \> versions.vc] \ || [nmakehlp -V $(ROOT)\configure.ac ^[$(PROJECT)^] >> versions.vc] !error *** Could not figure out extension version. Please define DOTVERSION in parent makefile before including rules.vc. !endif !endif !include versions.vc !endif # DOTVERSION VERSION = $(DOTVERSION:.=) !endif # $(DOING_TCL) ... etc. # Windows RC files have 3 version components. Ensure this irrespective # of how many components the package has specified. Basically, ensure # minimum 4 components by appending 4 0's and then pick out the first 4. # Also take care of the fact that DOTVERSION may have "a" or "b" instead # of "." separating the version components. DOTSEPARATED=$(DOTVERSION:a=.) DOTSEPARATED=$(DOTSEPARATED:b=.) !if [echo RCCOMMAVERSION = \> versions.vc] \ || [for /f "tokens=1,2,3,4,5* delims=." %a in ("$(DOTSEPARATED).0.0.0.0") do echo %a,%b,%c,%d >> versions.vc] !error *** Could not generate RCCOMMAVERSION *** !endif !include versions.vc ######################################################################## # 7. Parse the OPTS macro to work out the requested build configuration. # Based on this, we will construct the actual switches to be passed to the # compiler and linker using the macros defined in the previous section. # The following macros are defined by this section based on OPTS # STATIC_BUILD - 0 -> Tcl is to be built as a shared library # 1 -> build as a static library and shell # TCL_THREADS - legacy but always 1 on Windows since winsock requires it. # DEBUG - 1 -> debug build, 0 -> release builds # SYMBOLS - 1 -> generate PDB's, 0 -> no PDB's # PROFILE - 1 -> generate profiling info, 0 -> no profiling # PGO - 1 -> profile based optimization, 0 -> no # MSVCRT - 1 -> link to dynamic C runtime even when building static Tcl build # 0 -> link to static C runtime for static Tcl build. # Does not impact shared Tcl builds (STATIC_BUILD == 0) # Default: 1 for Tcl 8.7 and up, 0 otherwise. # TCL_USE_STATIC_PACKAGES - 1 -> statically link the registry and dde extensions # in the Tcl and Wish shell. 0 -> keep them as shared libraries. Does # not impact shared Tcl builds. Implied by STATIC_BUILD since Tcl 8.7. # USE_THREAD_ALLOC - 1 -> Use a shared global free pool for allocation. # 0 -> Use the non-thread allocator. # UNCHECKED - 1 -> when doing a debug build with symbols, use the release # C runtime, 0 -> use the debug C runtime. # USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking # CONFIG_CHECK - 1 -> check current build configuration against Tcl # configuration (ignored for Tcl itself) # _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build # (CRT library should support this, not needed for Tcl 9.x) # Further, LINKERFLAGS are modified based on above. # Default values for all the above STATIC_BUILD = 0 TCL_THREADS = 1 DEBUG = 0 SYMBOLS = 0 PROFILE = 0 PGO = 0 MSVCRT = 1 TCL_USE_STATIC_PACKAGES = 0 USE_THREAD_ALLOC = 1 UNCHECKED = 0 CONFIG_CHECK = 1 !if $(DOING_TCL) USE_STUBS = 0 !else USE_STUBS = 1 !endif # If OPTS is not empty AND does not contain "none" which turns off all OPTS # set the above macros based on OPTS content !if "$(OPTS)" != "" && ![nmakehlp -f "$(OPTS)" "none"] # OPTS are specified, parse them !if [nmakehlp -f $(OPTS) "static"] !message *** Doing static STATIC_BUILD = 1 !endif !if [nmakehlp -f $(OPTS) "nostubs"] !message *** Not using stubs USE_STUBS = 0 !endif !if [nmakehlp -f $(OPTS) "nomsvcrt"] !message *** Doing nomsvcrt MSVCRT = 0 !else !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt !else !if $(TCL_MAJOR_VERSION) == 8 && $(TCL_MINOR_VERSION) < 7 && $(STATIC_BUILD) MSVCRT = 0 !endif !endif !endif # [nmakehlp -f $(OPTS) "nomsvcrt"] !if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 !endif !if [nmakehlp -f $(OPTS) "nothreads"] !message *** Compile explicitly for non-threaded tcl TCL_THREADS = 0 USE_THREAD_ALLOC= 0 !endif !if [nmakehlp -f $(OPTS) "tcl8"] !message *** Build for Tcl8 TCL_BUILD_FOR = 8 !endif !if [nmakehlp -f $(OPTS) "tk8"] !message *** Build for Tk8 TK_BUILD_FOR = 8 !endif !if $(TCL_MAJOR_VERSION) == 8 !if [nmakehlp -f $(OPTS) "time64bit"] !message *** Force 64-bit time_t _USE_64BIT_TIME_T = 1 !endif !endif # Yes, it's weird that the "symbols" option controls DEBUG and # the "pdbs" option controls SYMBOLS. That's historical. !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols DEBUG = 1 !else DEBUG = 0 !endif !if [nmakehlp -f $(OPTS) "pdbs"] !message *** Doing pdbs SYMBOLS = 1 !else SYMBOLS = 0 !endif !if [nmakehlp -f $(OPTS) "profile"] !message *** Doing profile PROFILE = 1 !else PROFILE = 0 !endif !if [nmakehlp -f $(OPTS) "pgi"] !message *** Doing profile guided optimization instrumentation PGO = 1 !elseif [nmakehlp -f $(OPTS) "pgo"] !message *** Doing profile guided optimization PGO = 2 !else PGO = 0 !endif !if [nmakehlp -f $(OPTS) "loimpact"] !message *** Warning: ignoring option "loimpact" - deprecated on modern Windows. !endif # TBD - should get rid of this option !if [nmakehlp -f $(OPTS) "thrdalloc"] !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 !endif !if [nmakehlp -f $(OPTS) "tclalloc"] USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "unchecked"] !message *** Doing unchecked UNCHECKED = 1 !else UNCHECKED = 0 !endif !if [nmakehlp -f $(OPTS) "noconfigcheck"] CONFIG_CHECK = 1 !else CONFIG_CHECK = 0 !endif !endif # "$(OPTS)" != "" && ... parsing of OPTS # Set linker flags based on above !if $(PGO) > 1 !if [nmakehlp -l -ltcg:pgoptimize $(LINKER_TESTFLAGS)] LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pgoptimize !else MSG=^ This compiler does not support profile guided optimization. !error $(MSG) !endif !elseif $(PGO) > 0 !if [nmakehlp -l -ltcg:pginstrument $(LINKER_TESTFLAGS)] LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pginstrument !else MSG=^ This compiler does not support profile guided optimization. !error $(MSG) !endif !endif ################################################################ # 8. Parse the STATS macro to configure code instrumentation # The following macros are set by this section: # TCL_MEM_DEBUG - 1 -> enables memory allocation instrumentation # 0 -> disables # TCL_COMPILE_DEBUG - 1 -> enables byte compiler logging # 0 -> disables # Default both are off TCL_MEM_DEBUG = 0 TCL_COMPILE_DEBUG = 0 !if "$(STATS)" != "" && ![nmakehlp -f "$(STATS)" "none"] !if [nmakehlp -f $(STATS) "memdbg"] !message *** Doing memdbg TCL_MEM_DEBUG = 1 !else TCL_MEM_DEBUG = 0 !endif !if [nmakehlp -f $(STATS) "compdbg"] !message *** Doing compdbg TCL_COMPILE_DEBUG = 1 !else TCL_COMPILE_DEBUG = 0 !endif !endif #################################################################### # 9. Parse the CHECKS macro to configure additional compiler checks # The following macros are set by this section: # WARNINGS - compiler switches that control the warnings level # TCL_NO_DEPRECATED - 1 -> disable support for deprecated functions # 0 -> enable deprecated functions # Defaults - Permit deprecated functions and warning level 3 TCL_NO_DEPRECATED = 0 WARNINGS = -W3 !if "$(CHECKS)" != "" && ![nmakehlp -f "$(CHECKS)" "none"] !if [nmakehlp -f $(CHECKS) "nodep"] !message *** Doing nodep check TCL_NO_DEPRECATED = 1 !endif !if [nmakehlp -f $(CHECKS) "fullwarn"] !message *** Doing full warnings check WARNINGS = -W4 !if [nmakehlp -l -warn:3 $(LINKER_TESTFLAGS)] LINKERFLAGS = $(LINKERFLAGS) -warn:3 !endif !endif !if [nmakehlp -f $(CHECKS) "64bit"] && [nmakehlp -c -Wp64] !message *** Doing 64bit portability warnings WARNINGS = $(WARNINGS) -Wp64 !endif !endif ################################################################ # 10. Construct output directory and file paths # Figure-out how to name our intermediate and output directories. # In order to avoid inadvertent mixing of object files built using # different compilers, build configurations etc., # # Naming convention (suffixes): # t = full thread support. (Not used for Tcl >= 8.7) # s = static library (as opposed to an import library) # g = linked to the debug enabled C run-time. # x = special static build when it links to the dynamic C run-time. # # The following macros are set in this section: # SUFX - the suffix to use for binaries based on above naming convention # BUILDDIRTOP - the toplevel default output directory # is of the form {Release,Debug}[_AMD64][_COMPILERVERSION] # TMP_DIR - directory where object files are created # OUT_DIR - directory where output executables are created # Both TMP_DIR and OUT_DIR are defaulted only if not defined by the # parent makefile (or command line). The default values are # based on BUILDDIRTOP. # STUBPREFIX - name of the stubs library for this project # PRJIMPLIB - output path of the generated project import library # PRJLIBNAME - name of generated project library # PRJLIB - output path of generated project library # PRJSTUBLIBNAME - name of the generated project stubs library # PRJSTUBLIB - output path of the generated project stubs library # RESFILE - output resource file (only if not static build) SUFX = tsgx !if $(DEBUG) BUILDDIRTOP = Debug !else BUILDDIRTOP = Release !endif !if "$(MACHINE)" != "IX86" BUILDDIRTOP =$(BUILDDIRTOP)_$(MACHINE) !endif !if $(VCVER) > 6 BUILDDIRTOP =$(BUILDDIRTOP)_VC$(VCVER) !endif !if !$(DEBUG) || $(TCL_VERSION) > 86 || $(DEBUG) && $(UNCHECKED) SUFX = $(SUFX:g=) !endif TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX !if !$(STATIC_BUILD) TMP_DIRFULL = $(TMP_DIRFULL:Static=) SUFX = $(SUFX:s=) EXT = dll TMP_DIRFULL = $(TMP_DIRFULL:X=) SUFX = $(SUFX:x=) !else TMP_DIRFULL = $(TMP_DIRFULL:Dynamic=) EXT = lib !if $(MSVCRT) && $(TCL_VERSION) > 86 || !$(MSVCRT) && $(TCL_VERSION) < 87 TMP_DIRFULL = $(TMP_DIRFULL:X=) SUFX = $(SUFX:x=) !endif !endif !if !$(TCL_THREADS) || $(TCL_VERSION) > 86 TMP_DIRFULL = $(TMP_DIRFULL:Threaded=) SUFX = $(SUFX:t=) !endif !ifndef TMP_DIR TMP_DIR = $(TMP_DIRFULL) !ifndef OUT_DIR OUT_DIR = .\$(BUILDDIRTOP) !endif !else !ifndef OUT_DIR OUT_DIR = $(TMP_DIR) !endif !endif # Relative paths -> absolute !if [echo OUT_DIR = \> nmakehlp.out] \ || [nmakehlp -Q "$(OUT_DIR)" >> nmakehlp.out] !error *** Could not fully qualify path OUT_DIR=$(OUT_DIR) !endif !if [echo TMP_DIR = \>> nmakehlp.out] \ || [nmakehlp -Q "$(TMP_DIR)" >> nmakehlp.out] !error *** Could not fully qualify path TMP_DIR=$(TMP_DIR) !endif !include nmakehlp.out # The name of the stubs library for the project being built STUBPREFIX = $(PROJECT)stub # # Set up paths to various Tcl executables and libraries needed by extensions # # TIP 430. Unused for 8.6 but no harm defining it to allow a common rules.vc TCL_ZIP_FILE = libtcl$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)$(TCL_PATCH_LETTER)$(TCL_RELEASE_SERIAL).zip TK_ZIP_FILE = libtk$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION)$(TK_PATCH_LETTER)$(TK_RELEASE_SERIAL).zip !if $(DOING_TCL) TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe TCLSH = $(OUT_DIR)\$(TCLSHNAME) TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSCRIPTZIP = $(OUT_DIR)\$(TCL_ZIP_FILE) !if $(TCL_MAJOR_VERSION) == 8 TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib !else TCLSTUBLIBNAME = $(STUBPREFIX).lib !endif TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" !else # !$(DOING_TCL) !if $(TCLINSTALL) # Building against an installed Tcl # When building extensions, we need to locate tclsh. Depending on version # of Tcl we are building against, this may or may not have a "t" suffix. # Try various possibilities in turn. TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe !if !exist("$(TCLSH)") TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif !if $(TCL_MAJOR_VERSION) == 8 TCLSTUBLIB = $(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib !else TCLSTUBLIB = $(_TCLDIR)\lib\tclstub.lib !endif TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX:t=).lib # When building extensions, may be linking against Tcl that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. !if !exist("$(TCLIMPLIB)") TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)t$(SUFX:t=).lib !endif TCL_LIBRARY = $(_TCLDIR)\lib TCLREGLIB = $(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib TCLDDELIB = $(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib TCLSCRIPTZIP = $(_TCLDIR)\lib\$(TCL_ZIP_FILE) TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target TCL_INCLUDES = -I"$(_TCLDIR)\include" !else # Building against Tcl sources TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe !if !exist($(TCLSH)) TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif !if $(TCL_MAJOR_VERSION) == 8 TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib !else TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub.lib !endif TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib # When building extensions, may be linking against Tcl that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. !if !exist("$(TCLIMPLIB)") TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)t$(SUFX:t=).lib !endif TCL_LIBRARY = $(_TCLDIR)\library TCLREGLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib TCLDDELIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib TCLSCRIPTZIP = $(_TCLDIR)\win\$(BUILDDIRTOP)\$(TCL_ZIP_FILE) TCLTOOLSDIR = $(_TCLDIR)\tools TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" !endif # TCLINSTALL !if !$(STATIC_BUILD) && "$(TCL_BUILD_FOR)" == "8" tcllibs = "$(TCLSTUBLIB)" !else tcllibs = "$(TCLSTUBLIB)" "$(TCLIMPLIB)" !endif !endif # $(DOING_TCL) # We need a tclsh that will run on the host machine as part of the build. # IX86 runs on all architectures. !ifndef TCLSH_NATIVE !if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" TCLSH_NATIVE = $(TCLSH) !else !error You must explicitly set TCLSH_NATIVE for cross-compilation !endif !endif # Do the same for Tk and Tk extensions that require the Tk libraries !if $(DOING_TK) || $(NEED_TK) WISHNAMEPREFIX = wish WISHNAME = $(WISHNAMEPREFIX)$(TK_VERSION)$(SUFX).exe TKLIBNAME8 = tk$(TK_VERSION)$(SUFX).$(EXT) TKLIBNAME9 = tcl9tk$(TK_VERSION)$(SUFX).$(EXT) !if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8" TKLIBNAME = tk$(TK_VERSION)$(SUFX).$(EXT) TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib !else TKLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).$(EXT) TKIMPLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).lib !endif !if $(TK_MAJOR_VERSION) == 8 TKSTUBLIBNAME = tkstub$(TK_VERSION).lib !else TKSTUBLIBNAME = tkstub.lib !endif !if $(DOING_TK) WISH = $(OUT_DIR)\$(WISHNAME) TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) TKLIB = $(OUT_DIR)\$(TKLIBNAME) TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" TKSCRIPTZIP = $(OUT_DIR)\$(TK_ZIP_FILE) !else # effectively NEED_TK !if $(TKINSTALL) # Building against installed Tk WISH = $(_TKDIR)\bin\$(WISHNAME) TKSTUBLIB = $(_TKDIR)\lib\$(TKSTUBLIBNAME) TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME) # When building extensions, may be linking against Tk that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. !if !exist("$(TKIMPLIB)") TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME) !endif TK_INCLUDES = -I"$(_TKDIR)\include" TKSCRIPTZIP = $(_TKDIR)\lib\$(TK_ZIP_FILE) !else # Building against Tk sources WISH = $(_TKDIR)\win\$(BUILDDIRTOP)\$(WISHNAME) TKSTUBLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKSTUBLIBNAME) TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME) # When building extensions, may be linking against Tk that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. !if !exist("$(TKIMPLIB)") TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME) !endif TK_INCLUDES = -I"$(_TKDIR)\generic" -I"$(_TKDIR)\win" -I"$(_TKDIR)\xlib" TKSCRIPTZIP = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TK_ZIP_FILE) !endif # TKINSTALL tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" !endif # $(DOING_TK) !endif # $(DOING_TK) || $(NEED_TK) # Various output paths PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib PRJLIBNAME8 = $(PROJECT)$(VERSION)$(SUFX).$(EXT) # Even when building against Tcl 8, PRJLIBNAME9 must not have "t" PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX:t=).$(EXT) !if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8" PRJLIBNAME = $(PRJLIBNAME8) !else PRJLIBNAME = $(PRJLIBNAME9) !endif PRJLIB = $(OUT_DIR)\$(PRJLIBNAME) !if $(TCL_MAJOR_VERSION) == 8 PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib !else PRJSTUBLIBNAME = $(STUBPREFIX).lib !endif PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME) # If extension parent makefile has not defined a resource definition file, # we will generate one from standard template. !if !$(DOING_TCL) && !$(DOING_TK) && !$(STATIC_BUILD) !ifdef RCFILE RESFILE = $(TMP_DIR)\$(RCFILE:.rc=.res) !else RESFILE = $(TMP_DIR)\$(PROJECT).res !endif !endif ################################################################### # 11. Construct the paths for the installation directories # The following macros get defined in this section: # LIB_INSTALL_DIR - where libraries should be installed # BIN_INSTALL_DIR - where the executables should be installed # DOC_INSTALL_DIR - where documentation should be installed # SCRIPT_INSTALL_DIR - where scripts should be installed # INCLUDE_INSTALL_DIR - where C include files should be installed # DEMO_INSTALL_DIR - where demos should be installed # PRJ_INSTALL_DIR - where package will be installed (not set for Tcl and Tk) !if $(DOING_TCL) || $(DOING_TK) LIB_INSTALL_DIR = $(_INSTALLDIR)\lib BIN_INSTALL_DIR = $(_INSTALLDIR)\bin DOC_INSTALL_DIR = $(_INSTALLDIR)\doc !if $(DOING_TCL) SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) MODULE_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(TCL_MAJOR_VERSION) !else # DOING_TK SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) !endif DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include !else # extension other than Tk PRJ_INSTALL_DIR = $(_INSTALLDIR)\$(PROJECT)$(DOTVERSION) !if $(MULTIPLATFORM_INSTALL) LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY) BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY) !else LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR) BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR) !endif DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR) SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR) DEMO_INSTALL_DIR = $(PRJ_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\..\include !endif ################################################################### # 12. Set up actual options to be passed to the compiler and linker # Now we have all the information we need, set up the actual flags and # options that we will pass to the compiler and linker. The main # makefile should use these in combination with whatever other flags # and switches are specific to it. # The following macros are defined, names are for historical compatibility: # OPTDEFINES - /Dxxx C macro flags based on user-specified OPTS # COMPILERFLAGS - /Dxxx C macro flags independent of any configuration options # crt - Compiler switch that selects the appropriate C runtime # cdebug - Compiler switches related to debug AND optimizations # cwarn - Compiler switches that set warning levels # cflags - complete compiler switches (subsumes cdebug and cwarn) # ldebug - Linker switches controlling debug information and optimization # lflags - complete linker switches (subsumes ldebug) except subsystem type # dlllflags - complete linker switches to build DLLs (subsumes lflags) # conlflags - complete linker switches for console program (subsumes lflags) # guilflags - complete linker switches for GUI program (subsumes lflags) # baselibs - minimum Windows libraries required. Parent makefile can # define PRJ_LIBS before including rules.rc if additional libs are needed OPTDEFINES = /DSTDC_HEADERS /DUSE_NMAKE=1 !if $(VCVERSION) > 1600 OPTDEFINES = $(OPTDEFINES) /DHAVE_STDINT_H=1 !else OPTDEFINES = $(OPTDEFINES) /DMP_NO_STDINT=1 !endif !if $(VCVERSION) >= 1800 OPTDEFINES = $(OPTDEFINES) /DHAVE_INTTYPES_H=1 /DHAVE_STDBOOL_H=1 !endif !if $(TCL_MEM_DEBUG) OPTDEFINES = $(OPTDEFINES) /DTCL_MEM_DEBUG !endif !if $(TCL_COMPILE_DEBUG) OPTDEFINES = $(OPTDEFINES) /DTCL_COMPILE_DEBUG /DTCL_COMPILE_STATS !endif !if $(TCL_THREADS) && $(TCL_VERSION) < 87 OPTDEFINES = $(OPTDEFINES) /DTCL_THREADS=1 !if $(USE_THREAD_ALLOC) && $(TCL_VERSION) < 87 OPTDEFINES = $(OPTDEFINES) /DUSE_THREAD_ALLOC=1 !endif !endif !if $(STATIC_BUILD) OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD !elseif $(TCL_VERSION) > 86 OPTDEFINES = $(OPTDEFINES) /DTCL_WITH_EXTERNAL_TOMMATH !if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" OPTDEFINES = $(OPTDEFINES) /DMP_64BIT !endif !endif !if $(TCL_NO_DEPRECATED) OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED !endif !if $(USE_STUBS) # Note we do not define USE_TCL_STUBS even when building tk since some # test targets in tk do not use stubs !if !$(DOING_TCL) USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS !if $(NEED_TK) USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS !endif !endif !endif # USE_STUBS !if !$(DEBUG) OPTDEFINES = $(OPTDEFINES) /DNDEBUG !if $(OPTIMIZING) OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_OPTIMIZED !endif !endif !if $(PROFILE) OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_PROFILED !endif !if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT !endif !if $(VCVERSION) < 1300 OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !endif !if $(TCL_MAJOR_VERSION) == 8 !if "$(_USE_64BIT_TIME_T)" == "1" OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif !endif !if "$(TCL_BUILD_FOR)" == "8" OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8 !endif !if "$(TK_BUILD_FOR)" == "8" OPTDEFINES = $(OPTDEFINES) /DTK_MAJOR_VERSION=8 !endif # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME # so we pass both !if !$(DOING_TCL) && !$(DOING_TK) PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ /DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ /DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ /DMODULE_SCOPE=extern !endif # crt picks the C run time based on selected OPTS !if $(MSVCRT) !if $(DEBUG) && !$(UNCHECKED) crt = -MDd !else crt = -MD !endif !else !if $(DEBUG) && !$(UNCHECKED) crt = -MTd !else crt = -MT !endif !endif # cdebug includes compiler options for debugging as well as optimization. !if $(DEBUG) # In debugging mode, optimizations need to be disabled cdebug = -Zi -Od $(DEBUGFLAGS) !else cdebug = $(OPTIMIZATIONS) !if $(SYMBOLS) cdebug = $(cdebug) -Zi !endif !endif # $(DEBUG) # cwarn includes default warning levels, also C4090 (buggy) and C4146 is useless. cwarn = $(WARNINGS) -wd4090 -wd4146 !if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" # Disable pointer<->int warnings related to cast between different sizes # There are a gadzillion of these due to use of ClientData and # clutter up compiler # output increasing chance of a real warning getting lost. So disable them. # Eventually some day, Tcl will be 64-bit clean. cwarn = $(cwarn) -wd4311 -wd4312 !endif ### Common compiler options that are architecture specific !if "$(MACHINE)" == "ARM" carch = /D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE !else carch = !endif # cpuid is only available on intel machines !if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "AMD64" carch = $(carch) /DHAVE_CPUID=1 !endif !if $(DEBUG) # Turn warnings into errors cwarn = $(cwarn) -WX !endif INCLUDES = $(TCL_INCLUDES) $(TK_INCLUDES) $(PRJ_INCLUDES) !if !$(DOING_TCL) && !$(DOING_TK) INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WIN_DIR)" -I"$(COMPATDIR)" !endif # These flags are defined roughly in the order of the pre-reform # rules.vc/makefile.vc to help visually compare that the pre- and # post-reform build logs # cflags contains generic flags used for building practically all object files cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(cwarn) -Fp$(TMP_DIR)^\ $(cdebug) !if $(TCL_MAJOR_VERSION) == 8 && $(TCL_MINOR_VERSION) < 7 cflags = $(cflags) -DTcl_Size=int !endif # appcflags contains $(cflags) and flags for building the application # object files (e.g. tclsh, or wish) pkgcflags contains $(cflags) plus # flags used for building shared object files The two differ in the # BUILD_$(PROJECT) macro which should be defined only for the shared # library *implementation* and not for its caller interface appcflags_nostubs = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) appcflags = $(appcflags_nostubs) $(USE_STUBS_DEFS) pkgcflags = $(appcflags) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) # stubscflags contains $(cflags) plus flags used for building a stubs # library for the package. Note: /DSTATIC_BUILD is defined in # $(OPTDEFINES) only if the OPTS configuration indicates a static # library. However the stubs library is ALWAYS static hence included # here irrespective of the OPTS setting. # # TBD - tclvfs has a comment that stubs libs should not be compiled with -GL # without stating why. Tcl itself compiled stubs libs with this flag. # so we do not remove it from cflags. -GL may prevent extensions # compiled with one VC version to fail to link against stubs library # compiled with another VC version. Check for this and fix accordingly. stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) /Zl /GL- /DSTATIC_BUILD $(INCLUDES) $(USE_STUBS_DEFS) # Link flags !if $(DEBUG) ldebug = -debug -debugtype:cv !else ldebug = -release -opt:ref -opt:icf,3 !if $(SYMBOLS) ldebug = $(ldebug) -debug -debugtype:cv !endif !endif # Note: Profiling is currently only possible with the Visual Studio Enterprise !if $(PROFILE) ldebug= $(ldebug) -profile !endif ### Declarations common to all linker versions lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) !if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 lflags = $(lflags) -nodefaultlib:libucrt.lib !endif dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console guilflags = $(lflags) -subsystem:windows # Libraries that are required for every image. # Extensions should define any additional libraries with $(PRJ_LIBS) winlibs = kernel32.lib advapi32.lib !if $(NEED_TK) winlibs = $(winlibs) gdi32.lib user32.lib uxtheme.lib !endif # Avoid 'unresolved external symbol __security_cookie' errors. # c.f. http://support.microsoft.com/?id=894573 !if "$(MACHINE)" == "AMD64" !if $(VCVERSION) > 1399 && $(VCVERSION) < 1500 winlibs = $(winlibs) bufferoverflowU.lib !endif !endif baselibs = $(winlibs) $(PRJ_LIBS) !if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 baselibs = $(baselibs) ucrt.lib !endif ################################################################ # 13. Define standard commands, common make targets and implicit rules CCPKGCMD = $(cc32) $(pkgcflags) -Fo$(TMP_DIR)^\ CCAPPCMD = $(cc32) $(appcflags) -Fo$(TMP_DIR)^\ CCSTUBSCMD = $(cc32) $(stubscflags) -Fo$(TMP_DIR)^\ LIBCMD = $(lib32) -nologo $(LINKERFLAGS) -out:$@ DLLCMD = $(link32) $(dlllflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) CONEXECMD = $(link32) $(conlflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ $(TCL_INCLUDES) /DSTATIC_BUILD=$(STATIC_BUILD) \ /DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ /DCOMMAVERSION=$(RCCOMMAVERSION) \ /DDOTVERSION=\"$(DOTVERSION)\" \ /DVERSION=\"$(VERSION)\" \ /DSUFX=\"$(SUFX)\" \ /DPROJECT=\"$(PROJECT)\" \ /DPRJLIBNAME=\"$(PRJLIBNAME)\" !ifndef DEFAULT_BUILD_TARGET DEFAULT_BUILD_TARGET = $(PROJECT) !endif default-target: $(DEFAULT_BUILD_TARGET) !if $(MULTIPLATFORM_INSTALL) default-pkgindex: @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl @echo } else { >> $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME8)]] >> $(OUT_DIR)\pkgIndex.tcl @echo } >> $(OUT_DIR)\pkgIndex.tcl !else default-pkgindex: @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl @echo } else { >> $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PRJLIBNAME8)]] >> $(OUT_DIR)\pkgIndex.tcl @echo } >> $(OUT_DIR)\pkgIndex.tcl !endif default-pkgindex-tea: @if exist $(ROOT)\pkgIndex.tcl.in nmakehlp -s << $(ROOT)\pkgIndex.tcl.in > $(OUT_DIR)\pkgIndex.tcl @PACKAGE_VERSION@ $(DOTVERSION) @PACKAGE_NAME@ $(PRJ_PACKAGE_TCLNAME) @PACKAGE_TCLNAME@ $(PRJ_PACKAGE_TCLNAME) @PKG_LIB_FILE@ $(PRJLIBNAME) @PKG_LIB_FILE8@ $(PRJLIBNAME8) @PKG_LIB_FILE9@ $(PRJLIBNAME9) << default-install: default-install-binaries default-install-libraries !if $(SYMBOLS) default-install: default-install-pdbs !endif # Again to deal with historical brokenness, there is some confusion # in terminlogy. For extensions, the "install-binaries" was used to # locate target directory for *binary shared libraries* and thus # the appropriate macro is LIB_INSTALL_DIR since BIN_INSTALL_DIR is # for executables (exes). On the other hand the "install-libraries" # target is for *scripts* and should have been called "install-scripts". default-install-binaries: $(PRJLIB) @echo Installing binaries to '$(LIB_INSTALL_DIR)' @if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" @$(CPY) $(PRJLIB) "$(LIB_INSTALL_DIR)" >NUL # Alias for default-install-scripts default-install-libraries: default-install-scripts default-install-scripts: $(OUT_DIR)\pkgIndex.tcl @echo Installing libraries to '$(SCRIPT_INSTALL_DIR)' @if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)" @echo Installing package index in '$(SCRIPT_INSTALL_DIR)' @$(CPY) $(OUT_DIR)\pkgIndex.tcl $(SCRIPT_INSTALL_DIR) default-install-stubs: @echo Installing stubs library to '$(SCRIPT_INSTALL_DIR)' @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" @$(CPY) $(PRJSTUBLIB) "$(SCRIPT_INSTALL_DIR)" >NUL default-install-pdbs: @echo Installing PDBs to '$(LIB_INSTALL_DIR)' @if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" @$(CPY) "$(OUT_DIR)\*.pdb" "$(LIB_INSTALL_DIR)\" # "emacs font-lock highlighting fix default-install-docs-html: @echo Installing documentation files to '$(DOC_INSTALL_DIR)' @if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)" @if exist $(DOCDIR) for %f in ("$(DOCDIR)\*.html" "$(DOCDIR)\*.css" "$(DOCDIR)\*.png") do @$(COPY) %f "$(DOC_INSTALL_DIR)" default-install-docs-n: @echo Installing documentation files to '$(DOC_INSTALL_DIR)' @if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)" @if exist $(DOCDIR) for %f in ("$(DOCDIR)\*.n") do @$(COPY) %f "$(DOC_INSTALL_DIR)" default-install-demos: @echo Installing demos to '$(DEMO_INSTALL_DIR)' @if not exist "$(DEMO_INSTALL_DIR)" mkdir "$(DEMO_INSTALL_DIR)" @if exist $(DEMODIR) $(CPYDIR) "$(DEMODIR)" "$(DEMO_INSTALL_DIR)" default-clean: @echo Cleaning $(TMP_DIR)\* ... @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) @echo Cleaning $(WIN_DIR)\nmakehlp.obj, nmakehlp.exe ... @if exist $(WIN_DIR)\nmakehlp.obj del $(WIN_DIR)\nmakehlp.obj @if exist $(WIN_DIR)\nmakehlp.exe del $(WIN_DIR)\nmakehlp.exe @if exist $(WIN_DIR)\nmakehlp.out del $(WIN_DIR)\nmakehlp.out @echo Cleaning $(WIN_DIR)\nmhlp-out.txt ... @if exist $(WIN_DIR)\nmhlp-out.txt del $(WIN_DIR)\nmhlp-out.txt @echo Cleaning $(WIN_DIR)\_junk.pch ... @if exist $(WIN_DIR)\_junk.pch del $(WIN_DIR)\_junk.pch @echo Cleaning $(WIN_DIR)\vercl.x, vercl.i ... @if exist $(WIN_DIR)\vercl.x del $(WIN_DIR)\vercl.x @if exist $(WIN_DIR)\vercl.i del $(WIN_DIR)\vercl.i @echo Cleaning $(WIN_DIR)\versions.vc, version.vc ... @if exist $(WIN_DIR)\versions.vc del $(WIN_DIR)\versions.vc @if exist $(WIN_DIR)\version.vc del $(WIN_DIR)\version.vc default-hose: default-clean @echo Hosing $(OUT_DIR)\* ... @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) # Only for backward compatibility default-distclean: default-hose default-setup: @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) !if "$(TESTPAT)" != "" TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) !endif default-test: default-setup $(PROJECT) @set TCLLIBPATH=$(OUT_DIR:\=/) @if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)" cd "$(TESTDIR)" && $(DEBUGGER) $(TCLSH) all.tcl $(TESTFLAGS) default-shell: default-setup $(PROJECT) @set TCLLIBPATH=$(OUT_DIR:\=/) @if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)" $(DEBUGGER) $(TCLSH) # Generation of Windows version resource !ifdef RCFILE # Note: don't use $** in below rule because there may be other dependencies # and only the "main" rc must be passed to the resource compiler $(TMP_DIR)\$(PROJECT).res: $(RCDIR)\$(PROJECT).rc $(RESCMD) $(RCDIR)\$(PROJECT).rc !else # If parent makefile has not defined a resource definition file, # we will generate one from standard template. $(TMP_DIR)\$(PROJECT).res: $(TMP_DIR)\$(PROJECT).rc $(TMP_DIR)\$(PROJECT).rc: @$(COPY) << $(TMP_DIR)\$(PROJECT).rc #include VS_VERSION_INFO VERSIONINFO FILEVERSION COMMAVERSION PRODUCTVERSION COMMAVERSION FILEFLAGSMASK 0x3fL #ifdef DEBUG FILEFLAGS VS_FF_DEBUG #else FILEFLAGS 0x0L #endif FILEOS VOS_NT_WINDOWS32 FILETYPE VFT_DLL FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN BLOCK "040904b0" BEGIN VALUE "FileDescription", "Tcl extension " PROJECT VALUE "OriginalFilename", PRJLIBNAME VALUE "FileVersion", DOTVERSION VALUE "ProductName", "Package " PROJECT " for Tcl" VALUE "ProductVersion", DOTVERSION END END BLOCK "VarFileInfo" BEGIN VALUE "Translation", 0x409, 1200 END END << !endif # ifdef RCFILE !ifndef DISABLE_IMPLICIT_RULES DISABLE_IMPLICIT_RULES = 0 !endif !if !$(DISABLE_IMPLICIT_RULES) # Implicit rule definitions - only for building library objects. For stubs and # main application, the makefile should define explicit rules. {$(ROOT)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< $< << {$(WIN_DIR)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< $< << {$(GENERICDIR)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< $< << {$(COMPATDIR)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< $< << {$(RCDIR)}.rc{$(TMP_DIR)}.res: $(RESCMD) $< {$(WIN_DIR)}.rc{$(TMP_DIR)}.res: $(RESCMD) $< {$(TMP_DIR)}.rc{$(TMP_DIR)}.res: $(RESCMD) $< .SUFFIXES: .SUFFIXES:.c .rc !endif ################################################################ # 14. Sanity check selected options against Tcl build options # When building an extension, certain configuration options should # match the ones used when Tcl was built. Here we check and # warn on a mismatch. !if !$(DOING_TCL) !if $(TCLINSTALL) # Building against an installed Tcl !if exist("$(_TCLDIR)\lib\nmake\tcl.nmake") TCLNMAKECONFIG = "$(_TCLDIR)\lib\nmake\tcl.nmake" !endif !else # !$(TCLINSTALL) - building against Tcl source !if exist("$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl.nmake") TCLNMAKECONFIG = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl.nmake" !endif !endif # TCLINSTALL !if $(CONFIG_CHECK) !ifdef TCLNMAKECONFIG !include $(TCLNMAKECONFIG) !if defined(CORE_MACHINE) && "$(CORE_MACHINE)" != "$(MACHINE)" !error ERROR: Build target ($(MACHINE)) does not match the Tcl library architecture ($(CORE_MACHINE)). !endif !if $(TCL_VERSION) < 87 && defined(CORE_USE_THREAD_ALLOC) && $(CORE_USE_THREAD_ALLOC) != $(USE_THREAD_ALLOC) !message WARNING: Value of USE_THREAD_ALLOC ($(USE_THREAD_ALLOC)) does not match its Tcl core value ($(CORE_USE_THREAD_ALLOC)). !endif !if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG) !message WARNING: Value of DEBUG ($(DEBUG)) does not match its Tcl library configuration ($(DEBUG)). !endif !endif !endif # TCLNMAKECONFIG !endif # !$(DOING_TCL) #---------------------------------------------------------- # Display stats being used. #---------------------------------------------------------- !if !$(DOING_TCL) !message *** Building against Tcl at '$(_TCLDIR)' !endif !if !$(DOING_TK) && $(NEED_TK) !message *** Building against Tk at '$(_TKDIR)' !endif !message *** Intermediate directory will be '$(TMP_DIR)' !message *** Output directory will be '$(OUT_DIR)' !message *** Installation, if selected, will be in '$(_INSTALLDIR)' !message *** Suffix for binaries will be '$(SUFX)' !message *** Compiler version $(VCVER). Target $(MACHINE), host $(NATIVE_ARCH). !endif # ifdef _RULES_VC thread3.0.1/win/rules-ext.vc0000644003604700454610000000755114726633451014402 0ustar dgp771div# This file should only be included in makefiles for Tcl extensions, # NOT in the makefile for Tcl itself. !ifndef _RULES_EXT_VC # We need to run from the directory the parent makefile is located in. # nmake does not tell us what makefile was used to invoke it so parent # makefile has to set the MAKEFILEVC macro or we just make a guess and # warn if we think that is not the case. !if "$(MAKEFILEVC)" == "" !if exist("$(PROJECT).vc") MAKEFILEVC = $(PROJECT).vc !elseif exist("makefile.vc") MAKEFILEVC = makefile.vc !endif !endif # "$(MAKEFILEVC)" == "" !if !exist("$(MAKEFILEVC)") MSG = ^ You must run nmake from the directory containing the project makefile.^ If you are doing that and getting this message, set the MAKEFILEVC^ macro to the name of the project makefile. !message WARNING: $(MSG) !endif !if "$(PROJECT)" == "tcl" !error The rules-ext.vc file is not intended for Tcl itself. !endif # We extract version numbers using the nmakehlp program. For now use # the local copy of nmakehlp. Once we locate Tcl, we will use that # one if it is newer. !if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" !if [$(CC) -nologo -DNDEBUG "nmakehlp.c" -link -subsystem:console > nul] !endif !else !if [copy x86_64-w64-mingw32-nmakehlp.exe nmakehlp.exe >NUL] !endif !endif # First locate the Tcl directory that we are working with. !if "$(TCLDIR)" != "" _RULESDIR = $(TCLDIR:/=\) !else # If an installation path is specified, that is also the Tcl directory. # Also Tk never builds against an installed Tcl, it needs Tcl sources !if defined(INSTALLDIR) && "$(PROJECT)" != "tk" _RULESDIR=$(INSTALLDIR:/=\) !else # Locate Tcl sources !if [echo _RULESDIR = \> nmakehlp.out] \ || [nmakehlp -L generic\tcl.h >> nmakehlp.out] _RULESDIR = ..\..\tcl !else !include nmakehlp.out !endif !endif # defined(INSTALLDIR).... !endif # ifndef TCLDIR # Now look for the targets.vc file under the Tcl root. Note we check this # file and not rules.vc because the latter also exists on older systems. !if exist("$(_RULESDIR)\lib\nmake\targets.vc") # Building against installed Tcl _RULESDIR = $(_RULESDIR)\lib\nmake !elseif exist("$(_RULESDIR)\win\targets.vc") # Building against Tcl sources _RULESDIR = $(_RULESDIR)\win !else # If we have not located Tcl's targets file, most likely we are compiling # against an older version of Tcl and so must use our own support files. _RULESDIR = . !endif !if "$(_RULESDIR)" != "." # Potentially using Tcl's support files. If this extension has its own # nmake support files, need to compare the versions and pick newer. !if exist("rules.vc") # The extension has its own copy !if [echo TCL_RULES_MAJOR = \> versions.vc] \ && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MAJOR >> versions.vc] !endif !if [echo TCL_RULES_MINOR = \>> versions.vc] \ && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MINOR >> versions.vc] !endif !if [echo OUR_RULES_MAJOR = \>> versions.vc] \ && [nmakehlp -V "rules.vc" RULES_VERSION_MAJOR >> versions.vc] !endif !if [echo OUR_RULES_MINOR = \>> versions.vc] \ && [nmakehlp -V "rules.vc" RULES_VERSION_MINOR >> versions.vc] !endif !include versions.vc # We have a newer version of the support files, use them !if ($(TCL_RULES_MAJOR) != $(OUR_RULES_MAJOR)) || ($(TCL_RULES_MINOR) < $(OUR_RULES_MINOR)) _RULESDIR = . !endif !endif # if exist("rules.vc") !endif # if $(_RULESDIR) != "." # Let rules.vc know what copy of nmakehlp.c to use. NMAKEHLPC = $(_RULESDIR)\nmakehlp.c # Get rid of our internal defines before calling rules.vc !undef TCL_RULES_MAJOR !undef TCL_RULES_MINOR !undef OUR_RULES_MAJOR !undef OUR_RULES_MINOR !if exist("$(_RULESDIR)\rules.vc") !message *** Using $(_RULESDIR)\rules.vc !include "$(_RULESDIR)\rules.vc" !else !error *** Could not locate rules.vc in $(_RULESDIR) !endif !endif # _RULES_EXT_VCthread3.0.1/win/pkg.vc0000644003604700454610000000022614726633451013223 0ustar dgp771div# remember to change configure.ac as well when these change # (then re-autoconf) PACKAGE_MAJOR = 3 PACKAGE_MINOR = 0 PACKAGE_VERSION = "3.0.1" thread3.0.1/win/makefile.vc0000644003604700454610000000473214726633451014225 0ustar dgp771div#------------------------------------------------------------- -*- makefile -*- # # Makefile for thread extension # # Basic build, test and install # nmake /f makefile.vc INSTALLDIR=c:\tcl # nmake /f makefile.vc INSTALLDIR=c:\tcl test # nmake /f makefile.vc INSTALLDIR=c:\tcl install # # For other build options (debug, static etc.), # See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for # detailed documentation. # # In addition to the command line macros described there the following # may also be defined. # ADDOPTDEFINES - addition compiler options # ADDLINKOPTS - addition link options # E.g. # nmake -nologo -f makefile.vc TCLDIR=%TCLDIR% ... ADDOPTDEFINES="-I%LMDBDIR%" ADDLINKOPTS="%LMDBDIR%\Release\lmdb.lib" # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------------ PROJECT = thread RCFILE = thread.rc DOCDIR = $(ROOT)\doc\html PRJ_DEFINES = /D_CRT_SECURE_NO_DEPRECATE /D_CRT_NONSTDC_NO_DEPRECATE PRJ_DEFINES = $(PRJ_DEFINES) /D_CRT_SECURE_NO_WARNINGS PRJ_DEFINES = $(PRJ_DEFINES) $(ADDOPTDEFINES) -I$(TMP_DIR) PRJ_LIBS = $(ADDLINKOPTS) !include "rules-ext.vc" PRJ_OBJS = \ $(TMP_DIR)\threadNs.obj \ $(TMP_DIR)\threadCmd.obj \ $(TMP_DIR)\threadSvCmd.obj \ $(TMP_DIR)\threadSpCmd.obj \ $(TMP_DIR)\threadPoolCmd.obj \ $(TMP_DIR)\psGdbm.obj \ $(TMP_DIR)\psLmdb.obj \ $(TMP_DIR)\threadSvListCmd.obj \ $(TMP_DIR)\threadSvKeylistCmd.obj \ $(TMP_DIR)\tclXkeylist.obj !include "$(_RULESDIR)\targets.vc" install: default-install-docs-html pkgindex: default-pkgindex-tea $(ROOT)\manifest.uuid: copy $(WIN_DIR)\gitmanifest.in $(ROOT)\manifest.uuid git rev-parse HEAD >>$(ROOT)\manifest.uuid $(TMP_DIR)\threadUuid.h: $(ROOT)\manifest.uuid copy $(WIN_DIR)\threadUuid.h.in+$(ROOT)\manifest.uuid $(TMP_DIR)\threadUuid.h # Explicit dependency rules $(GENERICDIR)\psGdbm.c: $(GENERICDIR)\psGdbm.h $(GENERICDIR)\psLmdb.c: $(GENERICDIR)\psLmdb.h $(GENERICDIR)\threadCmd.c : $(GENERICDIR)\tclThreadInt.h $(TMP_DIR)\threadUuid.h $(GENERICDIR)\threadSpCmd.c : $(GENERICDIR)\tclThreadInt.h $(GENERICDIR)\threadSvCmd.c : $(GENERICDIR)\tclThreadInt.h $(GENERICDIR)\threadPoolCmd.c : $(GENERICDIR)\tclThreadInt.h $(GENERICDIR)\threadSvListCmd.c : $(GENERICDIR)\tclThreadInt.h $(GENERICDIR)\threadSvKeylistCmd.c : $(GENERICDIR)\tclThreadInt.h thread3.0.1/win/thread.rc0000644003604700454610000000257614726633451013717 0ustar dgp771div// Version resource script // #include #define RESOURCE_INCLUDED LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ #ifndef COMMAVERSION #define COMMAVERSION PACKAGE_MAJOR,PACKAGE_MINOR,0,0 #endif #ifndef DOTVERSION #define DOTVERSION PACKAGE_VERSION #endif #ifndef PRJLIBNAME #ifdef DEBUG #define PRJLIBNAME "thread" STRINGIFY(JOIN(PACKAGE_MAJOR,PACKAGE_MINOR)) "d.dll\0" #else #define PRJLIBNAME "thread" STRINGIFY(JOIN(PACKAGE_MAJOR,PACKAGE_MINOR)) ".dll\0" #endif #endif VS_VERSION_INFO VERSIONINFO FILEVERSION COMMAVERSION PRODUCTVERSION COMMAVERSION FILEFLAGSMASK 0x3fL #if DEBUG FILEFLAGS 0x1L #else FILEFLAGS 0x0L #endif FILEOS VOS_NT_WINDOWS32 FILETYPE VFT_DLL FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */ BEGIN VALUE "FileDescription", "Threading extension library for Tcl" VALUE "OriginalFilename", PRJLIBNAME VALUE "CompanyName", "NONE! Open-sourced with no owner\0" VALUE "FileVersion", DOTVERSION VALUE "LegalCopyright", "Under BSD license\0" VALUE "ProductName", "Tcl for Windows\0" VALUE "ProductVersion", DOTVERSION VALUE "Authors", "Brent Welch,\r\n" "Andreas Kupries, \r\n" "David Gravereaux,\r\n" "Zoran Vasiljevic" "\0" END END BLOCK "VarFileInfo" BEGIN VALUE "Translation", 0x409, 1200 END END thread3.0.1/win/CONFIG0000644003604700454610000000074414726633451013005 0ustar dgp771div# # This is how I run configure. You'll want to change the # pathnames to match your system, of course. # # Note the CC=gcc must be set *before* the "configure" is ran. # This is really needed, otherwise configure will not be able # to compile the small test file which checks the presence # of the MinGW build environment. It is *not* enough to use # "--enable-gcc" configure option; you *need* to define CC. # export CC=gcc sh ../configure --enable-threads --with-tcl=e:/tcl/win thread3.0.1/win/README.txt0000644003604700454610000000446414726633451013616 0ustar dgp771div I. Building the Tcl thread extension for Windows ================================================ Thread extension supports two build options: o. MinGW builds: ---------------- The extension can be compiled under Windows using the MinGW (http://www.mingw.org) environment. You can also download the ready-to-go copy of the MinGW from the same place you've downloaded this extension. You should compile the Tcl core with MinGW first. After that, you can compile the extension by running the configure/make from this directory. You can also use the CONFIG script to do this. You might want to edit the script to match your environment and then just do: sh CONFIG This should go smoothly, once you got Tcl core compiled ok. o. Microsoft MSVC++ build: -------------------------- Files in this directory may be useful if you have not set up your TEA (i.e., MinGW) environment and you're using the MSVC++ from Micro$oft. To build the extension invoke the following command: nmake -f makefile.vc INSTALLDIR= INSTALLDIR is the path of the Tcl distribution where tcl.h and other needed Tcl files are installed. To build against a Tcl source build instead, nmake -f makefile.vc TCLDIR= Please look into the makefile.vc file for more options etc. Alternatively, you can open the extension workspace and project files (thread_win.dsw and thread_win.dsp) from within the MSVC++ and press the F7 key to build the extension under the control of the MSVC IDE. NOTE: it is likely that the .dsw and .dsp files are out of date. At least Visual Studio 2017 was not able to open those files. II. Building optional support libraries ======================================= As of 2.6 release, this extension supports persistent shared variables. To use this functionality, you might need to download and compile some other supporting libraries. Currently, there is a simple implementation of shared variable persistency built atop of popular GNU Gdbm package. You can obtain the latest version of the Gdbm from: http://www.gnu.org/software/gdbm/gdbm.html. For the impatient, there are Windows ports of GNU Gdbm found on various places on the Internet. The easiest way to start is to go to the GnuWin32 project: http://sourceforge.net/projects/gnuwin32 and fetch yourself a compiled GNU Gdbm DLL. -EOF- thread3.0.1/unix/0000755003604700454610000000000014731057540012271 5ustar dgp771divthread3.0.1/unix/threadUnix.c0000644003604700454610000000140214726633451014552 0ustar dgp771div/* * threadUnix.c -- * * Unix specific aspects for the thread extension. * * see http://dev.activestate.com/doc/howto/thread_model.html * * Some of this code is based on work done by Richard Hipp on behalf of * Conservation Through Innovation, Limited, with their permission. * * Copyright (c) 1998 by Sun Microsystems, Inc. * Copyright (c) 1999,2000 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "../generic/tclThread.h" /* EOF $RCSfile: threadUnix.c,v $ */ /* Emacs Setup Variables */ /* Local Variables: */ /* mode: C */ /* indent-tabs-mode: nil */ /* c-basic-offset: 4 */ /* End: */ thread3.0.1/unix/CONFIG0000644003604700454610000000334214726633451013170 0ustar dgp771div#!/bin/sh # # This file contains collection of configure directives # for building the Threading extension. # # Comment-out next line if building with GCC compiler. # # CC=gcc; export CC # # # Tcl on Unix (uses public Tcl library) # ---------------------------------------------------- # ../configure --enable-threads # # As of 2.6, the threading extension supports persistent # shared variables. As an working example of this, there # is a simple wrapper for the popular Gdbm library. # Uncomment the following line if you like to compile the # Gdbm wrapper for persistent shared variables. # # ../configure --enable-threads --with-gdbm # # If your Gdbm library is not installed in one of the # default system locations (/usr/lib, /usr/local/lib ...) # please use following directive. Note that both library # file *and* includes should be located in "/my/gdbm". # Of course, you have to replace the "/my/gdbm" below # with the exact location, as found in your system: # # ../configure --enable-threads --with-gdbm=/my/gdbm # # # AOLserver 4.X; Uses public Tcl library. # ---------------------------------------------------- # nsdir="/usr/local/naviserver" # ../configure --enable-threads \ # --with-naviserver=$nsdir \ # --prefix=$nsdir --exec-prefix=$nsdir # # NaviServer/AOLserver uses its own package loading mechanism. # To load, just do "ns_eval package require thread" # at the NaviServer/AOLserver startup or later from any thread. # # # Mac OS X; Uses public Tcl library. # ---------------------------------------------------- # ../configure --enable-threads \ # --mandir=/usr/local/share/man \ # --libdir=/Library/Tcl \ # --with-tcl=/Library/Frameworks/Tcl.framework \ # --with-tclinclude=/Library/Frameworks/Tcl.framework/Headers # # EOF thread3.0.1/unix/README0000644003604700454610000000602714726633451013163 0ustar dgp771div I. Building the Tcl thread extension for Unix ============================================= Extension can be compiled on several Unix derivates including various distributions of Linux. Build process is pretty straightforward. I've checked some versions of Solaris, Linux and Darwin, but the extension should compile without problems on any Unix-like operating system with a proper pthreads library implementation. To build on Unix-like operating systems, start with the CONFIG script and see if there is already a combination of the "configure" options which may satisfy your needs. If not, you can run the configure script located in the root of the distribution directory with a choice of supported options yourself. If yes, you can uncomment corresponding lines from the CONFIG script and do: % sh CONFIG Either way, this will create a Makefile which you use to run "make" and "make install". You can use "make clean" to clean the directory from temporary compilation files and/or "make distclean" to additionaly remove local config files. You might want to do "make test" before doing the "make install" in order to run the regression tests on the package. To explore other building options, look into the CONFIG file for more information. Note for NaviServer/AOLserver users ------------------------ The extension can be compiled as a loadable module for the NaviServer/AOLserver version 4.0 or higher. In order to do this, use "--with-naviserver" configure option to specify the directory containing the NaviServer/AOLserver distribution. The CONFIG script has an example how to invoke configure in order to build the extension as NaviServer/AOLserver module. Note, however, that "make install" and "make test" targets are still not supported for NaviServer/AOLserver builds. This will be corrected in one of the future releases. To fine-tune, you might also want to make the tsv::* commands replace the NaviServer/AOLserver built-in nsv_* family of commands, since they are API compatible and provide richer command set plus advanced shared-object storage of shared data. Go to the generic/threadSvCmd.h file and look at the beginning of the file for the: /* #define NSV_COMPAT 1 */ So, uncomment the line, recompile and there you go. II. Building optional support libraries ======================================= As of 2.6 release, this extension supports persistent shared variables. To use this functionality, you might need to download and compile some other supporting libraries. Currently, there is a simple implementation of shared variable persistency built atop of popular GNU Gdbm package. You can obtain the latest version of the Gdbm package from the GNU website at: http://www.gnu.org/software/gdbm/gdbm.html To compile with GNU Gdbm support you must configure with --with-gdbm switch. This option, if used, will try to locate the Gdbm library on your system at couple of standard locations. You might override this behaviour by giving --with-gdbm=/some/dir. Note that both library file and the include file must then reside in this directory. -EOF- thread3.0.1/tclconfig/0000755003604700454610000000000014731057540013256 5ustar dgp771divthread3.0.1/tclconfig/install-sh0000644003604700454610000003577614726633515015307 0ustar dgp771div#!/bin/sh # install - install a program, script, or datafile scriptversion=2020-11-14.01; # UTC # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the # following copyright and license. # # Copyright (C) 1994 X Consortium # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN # AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- # TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. # # Except as contained in this notice, the name of the X Consortium shall not # be used in advertising or otherwise to promote the sale, use or other deal- # ings in this Software without prior written authorization from the X Consor- # tium. # # # FSF changes to this file are in the public domain. # # Calling this script install-sh is preferred over install.sh, to prevent # 'make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. tab=' ' nl=' ' IFS=" $tab$nl" # Set DOITPROG to "echo" to test this script. doit=${DOITPROG-} doit_exec=${doit:-exec} # Put in absolute file names if you don't have them in your path; # or use environment vars. chgrpprog=${CHGRPPROG-chgrp} chmodprog=${CHMODPROG-chmod} chownprog=${CHOWNPROG-chown} cmpprog=${CMPPROG-cmp} cpprog=${CPPROG-cp} mkdirprog=${MKDIRPROG-mkdir} mvprog=${MVPROG-mv} rmprog=${RMPROG-rm} stripprog=${STRIPPROG-strip} posix_mkdir= # Desired mode of installed file. mode=0755 # Create dirs (including intermediate dirs) using mode 755. # This is like GNU 'install' as of coreutils 8.32 (2020). mkdir_umask=22 backupsuffix= chgrpcmd= chmodcmd=$chmodprog chowncmd= mvcmd=$mvprog rmcmd="$rmprog -f" stripcmd= src= dst= dir_arg= dst_arg= copy_on_change=false is_target_a_directory=possibly usage="\ Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE or: $0 [OPTION]... SRCFILES... DIRECTORY or: $0 [OPTION]... -t DIRECTORY SRCFILES... or: $0 [OPTION]... -d DIRECTORIES... In the 1st form, copy SRCFILE to DSTFILE. In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. In the 4th, create DIRECTORIES. Options: --help display this help and exit. --version display version info and exit. -c (ignored) -C install only if different (preserve data modification time) -d create directories instead of installing files. -g GROUP $chgrpprog installed files to GROUP. -m MODE $chmodprog installed files to MODE. -o USER $chownprog installed files to USER. -p pass -p to $cpprog. -s $stripprog installed files. -S SUFFIX attempt to back up existing files, with suffix SUFFIX. -t DIRECTORY install into DIRECTORY. -T report an error if DSTFILE is a directory. Environment variables override the default commands: CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG By default, rm is invoked with -f; when overridden with RMPROG, it's up to you to specify -f if you want it. If -S is not specified, no backups are attempted. Email bug reports to bug-automake@gnu.org. Automake home page: https://www.gnu.org/software/automake/ " while test $# -ne 0; do case $1 in -c) ;; -C) copy_on_change=true;; -d) dir_arg=true;; -g) chgrpcmd="$chgrpprog $2" shift;; --help) echo "$usage"; exit $?;; -m) mode=$2 case $mode in *' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*) echo "$0: invalid mode: $mode" >&2 exit 1;; esac shift;; -o) chowncmd="$chownprog $2" shift;; -p) cpprog="$cpprog -p";; -s) stripcmd=$stripprog;; -S) backupsuffix="$2" shift;; -t) is_target_a_directory=always dst_arg=$2 # Protect names problematic for 'test' and other utilities. case $dst_arg in -* | [=\(\)!]) dst_arg=./$dst_arg;; esac shift;; -T) is_target_a_directory=never;; --version) echo "$0 $scriptversion"; exit $?;; --) shift break;; -*) echo "$0: invalid option: $1" >&2 exit 1;; *) break;; esac shift done # We allow the use of options -d and -T together, by making -d # take the precedence; this is for compatibility with GNU install. if test -n "$dir_arg"; then if test -n "$dst_arg"; then echo "$0: target directory not allowed when installing a directory." >&2 exit 1 fi fi if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. # Otherwise, the last argument is the destination. Remove it from $@. for arg do if test -n "$dst_arg"; then # $@ is not empty: it contains at least $arg. set fnord "$@" "$dst_arg" shift # fnord fi shift # arg dst_arg=$arg # Protect names problematic for 'test' and other utilities. case $dst_arg in -* | [=\(\)!]) dst_arg=./$dst_arg;; esac done fi if test $# -eq 0; then if test -z "$dir_arg"; then echo "$0: no input file specified." >&2 exit 1 fi # It's OK to call 'install-sh -d' without argument. # This can happen when creating conditional directories. exit 0 fi if test -z "$dir_arg"; then if test $# -gt 1 || test "$is_target_a_directory" = always; then if test ! -d "$dst_arg"; then echo "$0: $dst_arg: Is not a directory." >&2 exit 1 fi fi fi if test -z "$dir_arg"; then do_exit='(exit $ret); exit $ret' trap "ret=129; $do_exit" 1 trap "ret=130; $do_exit" 2 trap "ret=141; $do_exit" 13 trap "ret=143; $do_exit" 15 # Set umask so as not to create temps with too-generous modes. # However, 'strip' requires both read and write access to temps. case $mode in # Optimize common cases. *644) cp_umask=133;; *755) cp_umask=22;; *[0-7]) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac fi for src do # Protect names problematic for 'test' and other utilities. case $src in -* | [=\(\)!]) src=./$src;; esac if test -n "$dir_arg"; then dst=$src dstdir=$dst test -d "$dstdir" dstdir_status=$? # Don't chown directories that already exist. if test $dstdir_status = 0; then chowncmd="" fi else # Waiting for this to be detected by the "$cpprog $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if test ! -f "$src" && test ! -d "$src"; then echo "$0: $src does not exist." >&2 exit 1 fi if test -z "$dst_arg"; then echo "$0: no destination specified." >&2 exit 1 fi dst=$dst_arg # If destination is a directory, append the input filename. if test -d "$dst"; then if test "$is_target_a_directory" = never; then echo "$0: $dst_arg: Is a directory" >&2 exit 1 fi dstdir=$dst dstbase=`basename "$src"` case $dst in */) dst=$dst$dstbase;; *) dst=$dst/$dstbase;; esac dstdir_status=0 else dstdir=`dirname "$dst"` test -d "$dstdir" dstdir_status=$? fi fi case $dstdir in */) dstdirslash=$dstdir;; *) dstdirslash=$dstdir/;; esac obsolete_mkdir_used=false if test $dstdir_status != 0; then case $posix_mkdir in '') # With -d, create the new directory with the user-specified mode. # Otherwise, rely on $mkdir_umask. if test -n "$dir_arg"; then mkdir_mode=-m$mode else mkdir_mode= fi posix_mkdir=false # The $RANDOM variable is not portable (e.g., dash). Use it # here however when possible just to lower collision chance. tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ trap ' ret=$? rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null exit $ret ' 0 # Because "mkdir -p" follows existing symlinks and we likely work # directly in world-writeable /tmp, make sure that the '$tmpdir' # directory is successfully created first before we actually test # 'mkdir -p'. if (umask $mkdir_umask && $mkdirprog $mkdir_mode "$tmpdir" && exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1 then if test -z "$dir_arg" || { # Check for POSIX incompatibilities with -m. # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or # other-writable bit of parent directory when it shouldn't. # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. test_tmpdir="$tmpdir/a" ls_ld_tmpdir=`ls -ld "$test_tmpdir"` case $ls_ld_tmpdir in d????-?r-*) different_mode=700;; d????-?--*) different_mode=755;; *) false;; esac && $mkdirprog -m$different_mode -p -- "$test_tmpdir" && { ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"` test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" } } then posix_mkdir=: fi rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" else # Remove any dirs left behind by ancient mkdir implementations. rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null fi trap '' 0;; esac if $posix_mkdir && ( umask $mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else # mkdir does not conform to POSIX, # or it failed possibly due to a race condition. Create the # directory the slow way, step by step, checking for races as we go. case $dstdir in /*) prefix='/';; [-=\(\)!]*) prefix='./';; *) prefix='';; esac oIFS=$IFS IFS=/ set -f set fnord $dstdir shift set +f IFS=$oIFS prefixes= for d do test X"$d" = X && continue prefix=$prefix$d if test -d "$prefix"; then prefixes= else if $posix_mkdir; then (umask $mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break # Don't fail if two instances are running concurrently. test -d "$prefix" || exit 1 else case $prefix in *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; *) qprefix=$prefix;; esac prefixes="$prefixes '$qprefix'" fi fi prefix=$prefix/ done if test -n "$prefixes"; then # Don't fail if two instances are running concurrently. (umask $mkdir_umask && eval "\$doit_exec \$mkdirprog $prefixes") || test -d "$dstdir" || exit 1 obsolete_mkdir_used=true fi fi fi if test -n "$dir_arg"; then { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 else # Make a couple of temp file names in the proper directory. dsttmp=${dstdirslash}_inst.$$_ rmtmp=${dstdirslash}_rm.$$_ # Trap to clean up those temp files at exit. trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 # Copy the file name to the temp name. (umask $cp_umask && { test -z "$stripcmd" || { # Create $dsttmp read-write so that cp doesn't create it read-only, # which would cause strip to fail. if test -z "$doit"; then : >"$dsttmp" # No need to fork-exec 'touch'. else $doit touch "$dsttmp" fi } } && $doit_exec $cpprog "$src" "$dsttmp") && # and set any options; do chmod last to preserve setuid bits. # # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $cpprog $src $dsttmp" command. # { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && # If -C, don't bother to copy if it wouldn't change the file. if $copy_on_change && old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then rm -f "$dsttmp" else # If $backupsuffix is set, and the file being installed # already exists, attempt a backup. Don't worry if it fails, # e.g., if mv doesn't support -f. if test -n "$backupsuffix" && test -f "$dst"; then $doit $mvcmd -f "$dst" "$dst$backupsuffix" 2>/dev/null fi # Rename the file to the real destination. $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || # The rename failed, perhaps because mv can't rename something else # to itself, or perhaps because mv is so ancient that it does not # support -f. { # Now remove or move aside any old file at destination location. # We try this two ways since rm can't unlink itself on some # systems and the destination file might be busy for other # reasons. In this case, the final cleanup might fail but the new # file should still install successfully. { test ! -f "$dst" || $doit $rmcmd "$dst" 2>/dev/null || { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && { $doit $rmcmd "$rmtmp" 2>/dev/null; :; } } || { echo "$0: cannot unlink or rename $dst" >&2 (exit 1); exit 1 } } && # Now rename the file to the real destination. $doit $mvcmd "$dsttmp" "$dst" } fi || exit 1 trap '' 0 fi done # Local variables: # eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: thread3.0.1/tclconfig/tcl.m40000644003604700454610000040467314726633515014326 0ustar dgp771div# tcl.m4 -- # # This file provides a set of autoconf macros to help TEA-enable # a Tcl extension. # # Copyright (c) 1999-2000 Ajuba Solutions. # Copyright (c) 2002-2005 ActiveState Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. AC_PREREQ([2.69]) # Possible values for key variables defined: # # TEA_WINDOWINGSYSTEM - win32 aqua x11 (mirrors 'tk windowingsystem') # TEA_PLATFORM - windows unix # TEA_TK_EXTENSION - True if this is a Tk extension # #------------------------------------------------------------------------ # TEA_PATH_TCLCONFIG -- # # Locate the tclConfig.sh file and perform a sanity check on # the Tcl compile flags # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --with-tcl=... # # Defines the following vars: # TCL_BIN_DIR Full path to the directory containing # the tclConfig.sh file #------------------------------------------------------------------------ AC_DEFUN([TEA_PATH_TCLCONFIG], [ dnl TEA specific: Make sure we are initialized AC_REQUIRE([TEA_INIT]) # # Ok, lets find the tcl configuration # First, look for one uninstalled. # the alternative search directory is invoked by --with-tcl # if test x"${no_tcl}" = x ; then # we reset no_tcl in case something fails here no_tcl=true AC_ARG_WITH(tcl, AS_HELP_STRING([--with-tcl], [directory containing tcl configuration (tclConfig.sh)]), [with_tclconfig="${withval}"]) AC_ARG_WITH(tcl8, AS_HELP_STRING([--with-tcl8], [Compile for Tcl8 in Tcl9 environment]), [with_tcl8="${withval}"]) AC_MSG_CHECKING([for Tcl configuration]) AC_CACHE_VAL(ac_cv_c_tclconfig,[ # First check to see if --with-tcl was specified. if test x"${with_tclconfig}" != x ; then case "${with_tclconfig}" in */tclConfig.sh ) if test -f "${with_tclconfig}"; then AC_MSG_WARN([--with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself]) with_tclconfig="`echo "${with_tclconfig}" | sed 's!/tclConfig\.sh$!!'`" fi ;; esac if test -f "${with_tclconfig}/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd "${with_tclconfig}"; pwd)`" else AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh]) fi fi # then check for a private Tcl installation if test x"${ac_cv_c_tclconfig}" = x ; then for i in \ ../tcl \ `ls -dr ../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ ../../tcl \ `ls -dr ../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ ../../../tcl \ `ls -dr ../../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do if test "${TEA_PLATFORM}" = "windows" \ -a -f "$i/win/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/win; pwd)`" break fi if test -f "$i/unix/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" break fi done fi # on Darwin, check in Framework installation locations if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/Library/Frameworks/Tcl.framework 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/Network/Library/Frameworks/Tcl.framework 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/System/Library/Frameworks/Tcl.framework 2>/dev/null` \ ; do if test -f "$i/Tcl.framework/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/Tcl.framework; pwd)`" break fi done fi # TEA specific: on Windows, check in common installation locations if test "${TEA_PLATFORM}" = "windows" \ -a x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d C:/Tcl/lib 2>/dev/null` \ `ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i; pwd)`" break fi done fi # check in a few common install locations if test x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d ${libdir} 2>/dev/null` \ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/pkg/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ `ls -d /usr/lib/tcl9.0 2>/dev/null` \ `ls -d /usr/lib/tcl8.7 2>/dev/null` \ `ls -d /usr/lib/tcl8.6 2>/dev/null` \ `ls -d /usr/lib/tcl8.5 2>/dev/null` \ `ls -d /usr/local/lib/tcl9.0 2>/dev/null` \ `ls -d /usr/local/lib/tcl8.7 2>/dev/null` \ `ls -d /usr/local/lib/tcl8.6 2>/dev/null` \ `ls -d /usr/local/lib/tcl8.5 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl9.0 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl8.7 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl8.6 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl8.5 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i; pwd)`" break fi done fi # check in a few other private locations if test x"${ac_cv_c_tclconfig}" = x ; then for i in \ ${srcdir}/../tcl \ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do if test "${TEA_PLATFORM}" = "windows" \ -a -f "$i/win/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/win; pwd)`" break fi if test -f "$i/unix/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" break fi done fi ]) if test x"${ac_cv_c_tclconfig}" = x ; then TCL_BIN_DIR="# no Tcl configs found" AC_MSG_ERROR([Can't find Tcl configuration definitions. Use --with-tcl to specify a directory containing tclConfig.sh]) else no_tcl= TCL_BIN_DIR="${ac_cv_c_tclconfig}" AC_MSG_RESULT([found ${TCL_BIN_DIR}/tclConfig.sh]) fi fi ]) #------------------------------------------------------------------------ # TEA_PATH_TKCONFIG -- # # Locate the tkConfig.sh file # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --with-tk=... # # Defines the following vars: # TK_BIN_DIR Full path to the directory containing # the tkConfig.sh file #------------------------------------------------------------------------ AC_DEFUN([TEA_PATH_TKCONFIG], [ # # Ok, lets find the tk configuration # First, look for one uninstalled. # the alternative search directory is invoked by --with-tk # if test x"${no_tk}" = x ; then # we reset no_tk in case something fails here no_tk=true AC_ARG_WITH(tk, AS_HELP_STRING([--with-tk], [directory containing tk configuration (tkConfig.sh)]), [with_tkconfig="${withval}"]) AC_ARG_WITH(tk8, AS_HELP_STRING([--with-tk8], [Compile for Tk8 in Tk9 environment]), [with_tk8="${withval}"]) AC_MSG_CHECKING([for Tk configuration]) AC_CACHE_VAL(ac_cv_c_tkconfig,[ # First check to see if --with-tkconfig was specified. if test x"${with_tkconfig}" != x ; then case "${with_tkconfig}" in */tkConfig.sh ) if test -f "${with_tkconfig}"; then AC_MSG_WARN([--with-tk argument should refer to directory containing tkConfig.sh, not to tkConfig.sh itself]) with_tkconfig="`echo "${with_tkconfig}" | sed 's!/tkConfig\.sh$!!'`" fi ;; esac if test -f "${with_tkconfig}/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd "${with_tkconfig}"; pwd)`" else AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh]) fi fi # then check for a private Tk library if test x"${ac_cv_c_tkconfig}" = x ; then for i in \ ../tk \ `ls -dr ../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../tk[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \ ../../tk \ `ls -dr ../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../../tk[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \ ../../../tk \ `ls -dr ../../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../../../tk[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do if test "${TEA_PLATFORM}" = "windows" \ -a -f "$i/win/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i/win; pwd)`" break fi if test -f "$i/unix/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i/unix; pwd)`" break fi done fi # on Darwin, check in Framework installation locations if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tkconfig}" = x ; then for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ ; do if test -f "$i/Tk.framework/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i/Tk.framework; pwd)`" break fi done fi # check in a few common install locations if test x"${ac_cv_c_tkconfig}" = x ; then for i in `ls -d ${libdir} 2>/dev/null` \ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/pkg/lib 2>/dev/null` \ `ls -d /usr/lib/tk9.0 2>/dev/null` \ `ls -d /usr/lib/tk8.7 2>/dev/null` \ `ls -d /usr/lib/tk8.6 2>/dev/null` \ `ls -d /usr/lib/tk8.5 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ `ls -d /usr/local/lib/tk9.0 2>/dev/null` \ `ls -d /usr/local/lib/tk8.7 2>/dev/null` \ `ls -d /usr/local/lib/tk8.6 2>/dev/null` \ `ls -d /usr/local/lib/tk8.5 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tk9.0 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tk8.7 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tk8.6 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tk8.5 2>/dev/null` \ ; do if test -f "$i/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i; pwd)`" break fi done fi # TEA specific: on Windows, check in common installation locations if test "${TEA_PLATFORM}" = "windows" \ -a x"${ac_cv_c_tkconfig}" = x ; then for i in `ls -d C:/Tcl/lib 2>/dev/null` \ `ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \ ; do if test -f "$i/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i; pwd)`" break fi done fi # check in a few other private locations if test x"${ac_cv_c_tkconfig}" = x ; then for i in \ ${srcdir}/../tk \ `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do if test "${TEA_PLATFORM}" = "windows" \ -a -f "$i/win/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i/win; pwd)`" break fi if test -f "$i/unix/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i/unix; pwd)`" break fi done fi ]) if test x"${ac_cv_c_tkconfig}" = x ; then TK_BIN_DIR="# no Tk configs found" AC_MSG_ERROR([Can't find Tk configuration definitions. Use --with-tk to specify a directory containing tkConfig.sh]) else no_tk= TK_BIN_DIR="${ac_cv_c_tkconfig}" AC_MSG_RESULT([found ${TK_BIN_DIR}/tkConfig.sh]) fi fi ]) #------------------------------------------------------------------------ # TEA_LOAD_TCLCONFIG -- # # Load the tclConfig.sh file # # Arguments: # # Requires the following vars to be set: # TCL_BIN_DIR # # Results: # # Substitutes the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE # TCL_ZIP_FILE # TCL_ZIPFS_SUPPORT #------------------------------------------------------------------------ AC_DEFUN([TEA_LOAD_TCLCONFIG], [ AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh]) if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then AC_MSG_RESULT([loading]) . "${TCL_BIN_DIR}/tclConfig.sh" else AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh]) fi # If the TCL_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable TCL_LIB_SPEC will be set to the value # of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC # instead of TCL_BUILD_LIB_SPEC since it will work with both an # installed and uninstalled version of Tcl. if test -f "${TCL_BIN_DIR}/Makefile" ; then TCL_LIB_SPEC="${TCL_BUILD_LIB_SPEC}" TCL_STUB_LIB_SPEC="${TCL_BUILD_STUB_LIB_SPEC}" TCL_STUB_LIB_PATH="${TCL_BUILD_STUB_LIB_PATH}" elif test "`uname -s`" = "Darwin"; then # If Tcl was built as a framework, attempt to use the libraries # from the framework at the given location so that linking works # against Tcl.framework installed in an arbitrary location. case ${TCL_DEFS} in *TCL_FRAMEWORK*) if test -f "${TCL_BIN_DIR}/${TCL_LIB_FILE}"; then for i in "`cd "${TCL_BIN_DIR}"; pwd`" \ "`cd "${TCL_BIN_DIR}"/../..; pwd`"; do if test "`basename "$i"`" = "${TCL_LIB_FILE}.framework"; then TCL_LIB_SPEC="-F`dirname "$i" | sed -e 's/ /\\\\ /g'` -framework ${TCL_LIB_FILE}" break fi done fi if test -f "${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}"; then TCL_STUB_LIB_SPEC="-L`echo "${TCL_BIN_DIR}" | sed -e 's/ /\\\\ /g'` ${TCL_STUB_LIB_FLAG}" TCL_STUB_LIB_PATH="${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}" fi ;; esac fi AC_SUBST(TCL_VERSION) AC_SUBST(TCL_PATCH_LEVEL) AC_SUBST(TCL_BIN_DIR) AC_SUBST(TCL_SRC_DIR) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) AC_SUBST(TCL_STUB_LIB_FLAG) AC_SUBST(TCL_STUB_LIB_SPEC) AC_MSG_CHECKING([platform]) hold_cc=$CC; CC="$TCL_CC" AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[ #ifdef _WIN32 #error win32 #endif ]])],[ # first test we've already retrieved platform (cross-compile), fallback to unix otherwise: TEA_PLATFORM="${TEA_PLATFORM-unix}" CYGPATH=echo ],[ TEA_PLATFORM="windows" AC_CHECK_PROG(CYGPATH, cygpath, cygpath -m, echo) ]) CC=$hold_cc AC_MSG_RESULT($TEA_PLATFORM) # The BUILD_$pkg is to define the correct extern storage class # handling when making this package AC_DEFINE_UNQUOTED(BUILD_${PACKAGE_NAME}, [], [Building extension source?]) # Do this here as we have fully defined TEA_PLATFORM now if test "${TEA_PLATFORM}" = "windows" ; then EXEEXT=".exe" CLEANFILES="$CLEANFILES *.lib *.dll *.pdb *.exp" fi # TEA specific: AC_SUBST(CLEANFILES) AC_SUBST(TCL_LIBS) AC_SUBST(TCL_DEFS) AC_SUBST(TCL_EXTRA_CFLAGS) AC_SUBST(TCL_LD_FLAGS) AC_SUBST(TCL_SHLIB_LD_LIBS) ]) #------------------------------------------------------------------------ # TEA_LOAD_TKCONFIG -- # # Load the tkConfig.sh file # # Arguments: # # Requires the following vars to be set: # TK_BIN_DIR # # Results: # # Sets the following vars that should be in tkConfig.sh: # TK_BIN_DIR #------------------------------------------------------------------------ AC_DEFUN([TEA_LOAD_TKCONFIG], [ AC_MSG_CHECKING([for existence of ${TK_BIN_DIR}/tkConfig.sh]) if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then AC_MSG_RESULT([loading]) . "${TK_BIN_DIR}/tkConfig.sh" else AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh]) fi # If the TK_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable TK_LIB_SPEC will be set to the value # of TK_BUILD_LIB_SPEC. An extension should make use of TK_LIB_SPEC # instead of TK_BUILD_LIB_SPEC since it will work with both an # installed and uninstalled version of Tcl. if test -f "${TK_BIN_DIR}/Makefile" ; then TK_LIB_SPEC="${TK_BUILD_LIB_SPEC}" TK_STUB_LIB_SPEC="${TK_BUILD_STUB_LIB_SPEC}" TK_STUB_LIB_PATH="${TK_BUILD_STUB_LIB_PATH}" elif test "`uname -s`" = "Darwin"; then # If Tk was built as a framework, attempt to use the libraries # from the framework at the given location so that linking works # against Tk.framework installed in an arbitrary location. case ${TK_DEFS} in *TK_FRAMEWORK*) if test -f "${TK_BIN_DIR}/${TK_LIB_FILE}"; then for i in "`cd "${TK_BIN_DIR}"; pwd`" \ "`cd "${TK_BIN_DIR}"/../..; pwd`"; do if test "`basename "$i"`" = "${TK_LIB_FILE}.framework"; then TK_LIB_SPEC="-F`dirname "$i" | sed -e 's/ /\\\\ /g'` -framework ${TK_LIB_FILE}" break fi done fi if test -f "${TK_BIN_DIR}/${TK_STUB_LIB_FILE}"; then TK_STUB_LIB_SPEC="-L` echo "${TK_BIN_DIR}" | sed -e 's/ /\\\\ /g'` ${TK_STUB_LIB_FLAG}" TK_STUB_LIB_PATH="${TK_BIN_DIR}/${TK_STUB_LIB_FILE}" fi ;; esac fi # TEA specific: Ensure windowingsystem is defined if test "${TEA_PLATFORM}" = "unix" ; then case ${TK_DEFS} in *MAC_OSX_TK*) AC_DEFINE(MAC_OSX_TK, 1, [Are we building against Mac OS X TkAqua?]) TEA_WINDOWINGSYSTEM="aqua" ;; *) TEA_WINDOWINGSYSTEM="x11" ;; esac elif test "${TEA_PLATFORM}" = "windows" ; then TEA_WINDOWINGSYSTEM="win32" fi AC_SUBST(TK_VERSION) AC_SUBST(TK_BIN_DIR) AC_SUBST(TK_SRC_DIR) AC_SUBST(TK_LIB_FILE) AC_SUBST(TK_LIB_FLAG) AC_SUBST(TK_LIB_SPEC) AC_SUBST(TK_STUB_LIB_FILE) AC_SUBST(TK_STUB_LIB_FLAG) AC_SUBST(TK_STUB_LIB_SPEC) # TEA specific: AC_SUBST(TK_LIBS) AC_SUBST(TK_XINCLUDES) ]) #------------------------------------------------------------------------ # TEA_PROG_TCLSH # Determine the fully qualified path name of the tclsh executable # in the Tcl build directory or the tclsh installed in a bin # directory. This macro will correctly determine the name # of the tclsh executable even if tclsh has not yet been # built in the build directory. The tclsh found is always # associated with a tclConfig.sh file. This tclsh should be used # only for running extension test cases. It should never be # or generation of files (like pkgIndex.tcl) at build time. # # Arguments: # none # # Results: # Substitutes the following vars: # TCLSH_PROG #------------------------------------------------------------------------ AC_DEFUN([TEA_PROG_TCLSH], [ AC_MSG_CHECKING([for tclsh]) if test -f "${TCL_BIN_DIR}/Makefile" ; then # tclConfig.sh is in Tcl build directory if test "${TEA_PLATFORM}" = "windows"; then if test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}" ; then TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}" elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}s${EXEEXT}" ; then TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}s${EXEEXT}" elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}t${EXEEXT}" ; then TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}t${EXEEXT}" elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}st${EXEEXT}" ; then TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}st${EXEEXT}" fi else TCLSH_PROG="${TCL_BIN_DIR}/tclsh" fi else # tclConfig.sh is in install location if test "${TEA_PLATFORM}" = "windows"; then TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}" else TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}" fi list="`ls -d ${TCL_BIN_DIR}/../bin 2>/dev/null` \ `ls -d ${TCL_BIN_DIR}/.. 2>/dev/null` \ `ls -d ${TCL_PREFIX}/bin 2>/dev/null`" for i in $list ; do if test -f "$i/${TCLSH_PROG}" ; then REAL_TCL_BIN_DIR="`cd "$i"; pwd`/" break fi done TCLSH_PROG="${REAL_TCL_BIN_DIR}${TCLSH_PROG}" fi AC_MSG_RESULT([${TCLSH_PROG}]) AC_SUBST(TCLSH_PROG) ]) #------------------------------------------------------------------------ # TEA_PROG_WISH # Determine the fully qualified path name of the wish executable # in the Tk build directory or the wish installed in a bin # directory. This macro will correctly determine the name # of the wish executable even if wish has not yet been # built in the build directory. The wish found is always # associated with a tkConfig.sh file. This wish should be used # only for running extension test cases. It should never be # or generation of files (like pkgIndex.tcl) at build time. # # Arguments: # none # # Results: # Substitutes the following vars: # WISH_PROG #------------------------------------------------------------------------ AC_DEFUN([TEA_PROG_WISH], [ AC_MSG_CHECKING([for wish]) if test -f "${TK_BIN_DIR}/Makefile" ; then # tkConfig.sh is in Tk build directory if test "${TEA_PLATFORM}" = "windows"; then if test -f "${TK_BIN_DIR}/wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}${EXEEXT}" ; then WISH_PROG="${TK_BIN_DIR}/wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}${EXEEXT}" elif test -f "${TK_BIN_DIR}/wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}s${EXEEXT}" ; then WISH_PROG="${TK_BIN_DIR}/wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}$s{EXEEXT}" elif test -f "${TK_BIN_DIR}/wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}t${EXEEXT}" ; then WISH_PROG="${TK_BIN_DIR}/wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}t${EXEEXT}" elif test -f "${TK_BIN_DIR}/wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}st${EXEEXT}" ; then WISH_PROG="${TK_BIN_DIR}/wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}st${EXEEXT}" fi else WISH_PROG="${TK_BIN_DIR}/wish" fi else # tkConfig.sh is in install location if test "${TEA_PLATFORM}" = "windows"; then WISH_PROG="wish${TK_MAJOR_VERSION}${TK_MINOR_VERSION}${EXEEXT}" else WISH_PROG="wish${TK_MAJOR_VERSION}.${TK_MINOR_VERSION}" fi list="`ls -d ${TK_BIN_DIR}/../bin 2>/dev/null` \ `ls -d ${TK_BIN_DIR}/.. 2>/dev/null` \ `ls -d ${TK_PREFIX}/bin 2>/dev/null`" for i in $list ; do if test -f "$i/${WISH_PROG}" ; then REAL_TK_BIN_DIR="`cd "$i"; pwd`/" break fi done WISH_PROG="${REAL_TK_BIN_DIR}${WISH_PROG}" fi AC_MSG_RESULT([${WISH_PROG}]) AC_SUBST(WISH_PROG) ]) #------------------------------------------------------------------------ # TEA_ENABLE_SHARED -- # # Allows the building of shared libraries # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --enable-shared=yes|no # --enable-stubs=yes|no # # Defines the following vars: # STATIC_BUILD Used for building import/export libraries # on Windows. # # Sets the following vars: # SHARED_BUILD Value of 1 or 0 # STUBS_BUILD Value if 1 or 0 # USE_TCL_STUBS Value true: if SHARED_BUILD or --enable-stubs # USE_TCLOO_STUBS Value true: if SHARED_BUILD or --enable-stubs # USE_TK_STUBS Value true: if SHARED_BUILD or --enable-stubs # AND TEA_WINDOWING_SYSTEM != "" #------------------------------------------------------------------------ AC_DEFUN([TEA_ENABLE_SHARED], [ AC_MSG_CHECKING([how to build libraries]) AC_ARG_ENABLE(shared, AS_HELP_STRING([--enable-shared], [build and link with shared libraries (default: on)]), [shared_ok=$enableval], [shared_ok=yes]) if test "${enable_shared+set}" = set; then enableval="$enable_shared" shared_ok=$enableval else shared_ok=yes fi AC_ARG_ENABLE(stubs, AS_HELP_STRING([--enable-stubs], [build and link with stub libraries. Always true for shared builds (default: on)]), [stubs_ok=$enableval], [stubs_ok=yes]) if test "${enable_stubs+set}" = set; then enableval="$enable_stubs" stubs_ok=$enableval else stubs_ok=yes fi # Stubs are always enabled for shared builds if test "$shared_ok" = "yes" ; then AC_MSG_RESULT([shared]) SHARED_BUILD=1 STUBS_BUILD=1 else AC_MSG_RESULT([static]) SHARED_BUILD=0 AC_DEFINE(STATIC_BUILD, 1, [This a static build]) if test "$stubs_ok" = "yes" ; then STUBS_BUILD=1 else STUBS_BUILD=0 fi fi if test "${STUBS_BUILD}" = "1" ; then AC_DEFINE(USE_TCL_STUBS, 1, [Use Tcl stubs]) AC_DEFINE(USE_TCLOO_STUBS, 1, [Use TclOO stubs]) if test "${TEA_WINDOWINGSYSTEM}" != ""; then AC_DEFINE(USE_TK_STUBS, 1, [Use Tk stubs]) fi fi AC_SUBST(SHARED_BUILD) AC_SUBST(STUBS_BUILD) ]) #------------------------------------------------------------------------ # TEA_ENABLE_THREADS -- # # Specify if thread support should be enabled. If "yes" is specified # as an arg (optional), threads are enabled by default, "no" means # threads are disabled. "yes" is the default. # # TCL_THREADS is checked so that if you are compiling an extension # against a threaded core, your extension must be compiled threaded # as well. # # Note that it is legal to have a thread enabled extension run in a # threaded or non-threaded Tcl core, but a non-threaded extension may # only run in a non-threaded Tcl core. # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --enable-threads # # Sets the following vars: # THREADS_LIBS Thread library(s) # # Defines the following vars: # TCL_THREADS # _REENTRANT # _THREAD_SAFE #------------------------------------------------------------------------ AC_DEFUN([TEA_ENABLE_THREADS], [ AC_ARG_ENABLE(threads, AS_HELP_STRING([--enable-threads], [build with threads (default: on)]), [tcl_ok=$enableval], [tcl_ok=yes]) if test "${enable_threads+set}" = set; then enableval="$enable_threads" tcl_ok=$enableval else tcl_ok=yes fi if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then TCL_THREADS=1 if test "${TEA_PLATFORM}" != "windows" ; then # We are always OK on Windows, so check what this platform wants: # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention AC_DEFINE(USE_THREAD_ALLOC, 1, [Do we want to use the threaded memory allocator?]) AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) if test "`uname -s`" = "SunOS" ; then AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) fi AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?]) AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) if test "$tcl_ok" = "no"; then # Check a little harder for __pthread_mutex_init in the same # library, as some systems hide it there until pthread.h is # defined. We could alternatively do an AC_TRY_COMPILE with # pthread.h, but that will work with libpthread really doesn't # exist, like AIX 4.2. [Bug: 4359] AC_CHECK_LIB(pthread, __pthread_mutex_init, tcl_ok=yes, tcl_ok=no) fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthread" else AC_CHECK_LIB(pthreads, pthread_mutex_init, tcl_ok=yes, tcl_ok=no) if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthreads" else AC_CHECK_LIB(c, pthread_mutex_init, tcl_ok=yes, tcl_ok=no) if test "$tcl_ok" = "no"; then AC_CHECK_LIB(c_r, pthread_mutex_init, tcl_ok=yes, tcl_ok=no) if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -pthread" else TCL_THREADS=0 AC_MSG_WARN([Do not know how to find pthread lib on your system - thread support disabled]) fi fi fi fi fi else TCL_THREADS=0 fi # Do checking message here to not mess up interleaved configure output AC_MSG_CHECKING([for building with threads]) if test "${TCL_THREADS}" = 1; then AC_DEFINE(TCL_THREADS, 1, [Are we building with threads enabled?]) AC_MSG_RESULT([yes (default)]) else AC_MSG_RESULT([no]) fi # TCL_THREADS sanity checking. See if our request for building with # threads is the same as the way Tcl was built. If not, warn the user. case ${TCL_DEFS} in *THREADS=1*) if test "${TCL_THREADS}" = "0"; then AC_MSG_WARN([ Building ${PACKAGE_NAME} without threads enabled, but building against Tcl that IS thread-enabled. It is recommended to use --enable-threads.]) fi ;; esac AC_SUBST(TCL_THREADS) ]) #------------------------------------------------------------------------ # TEA_ENABLE_SYMBOLS -- # # Specify if debugging symbols should be used. # Memory (TCL_MEM_DEBUG) debugging can also be enabled. # # Arguments: # none # # TEA varies from core Tcl in that C|LDFLAGS_DEFAULT receives # the value of C|LDFLAGS_OPTIMIZE|DEBUG already substituted. # Requires the following vars to be set in the Makefile: # CFLAGS_DEFAULT # LDFLAGS_DEFAULT # # Results: # # Adds the following arguments to configure: # --enable-symbols # # Defines the following vars: # CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true # Sets to "$(CFLAGS_OPTIMIZE) -DNDEBUG" if false # LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true # Sets to $(LDFLAGS_OPTIMIZE) if false #------------------------------------------------------------------------ AC_DEFUN([TEA_ENABLE_SYMBOLS], [ dnl TEA specific: Make sure we are initialized AC_REQUIRE([TEA_CONFIG_CFLAGS]) AC_MSG_CHECKING([for build with symbols]) AC_ARG_ENABLE(symbols, AS_HELP_STRING([--enable-symbols], [build with debugging symbols (default: off)]), [tcl_ok=$enableval], [tcl_ok=no]) if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT="${CFLAGS_OPTIMIZE} -DNDEBUG" LDFLAGS_DEFAULT="${LDFLAGS_OPTIMIZE}" AC_MSG_RESULT([no]) AC_DEFINE(TCL_CFG_OPTIMIZED, 1, [Is this an optimized build?]) else CFLAGS_DEFAULT="${CFLAGS_DEBUG}" LDFLAGS_DEFAULT="${LDFLAGS_DEBUG}" if test "$tcl_ok" = "yes"; then AC_MSG_RESULT([yes (standard debugging)]) fi fi AC_SUBST(CFLAGS_DEFAULT) AC_SUBST(LDFLAGS_DEFAULT) if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then AC_DEFINE(TCL_MEM_DEBUG, 1, [Is memory debugging enabled?]) fi if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then if test "$tcl_ok" = "all"; then AC_MSG_RESULT([enabled symbols mem debugging]) else AC_MSG_RESULT([enabled $tcl_ok debugging]) fi fi ]) #------------------------------------------------------------------------ # TEA_ENABLE_LANGINFO -- # # Allows use of modern nl_langinfo check for better l10n. # This is only relevant for Unix. # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --enable-langinfo=yes|no (default is yes) # # Defines the following vars: # HAVE_LANGINFO Triggers use of nl_langinfo if defined. #------------------------------------------------------------------------ AC_DEFUN([TEA_ENABLE_LANGINFO], [ AC_ARG_ENABLE(langinfo, AS_HELP_STRING([--enable-langinfo], [use nl_langinfo if possible to determine encoding at startup, otherwise use old heuristic (default: on)]), [langinfo_ok=$enableval], [langinfo_ok=yes]) HAVE_LANGINFO=0 if test "$langinfo_ok" = "yes"; then AC_CHECK_HEADER(langinfo.h,[langinfo_ok=yes],[langinfo_ok=no]) fi AC_MSG_CHECKING([whether to use nl_langinfo]) if test "$langinfo_ok" = "yes"; then AC_CACHE_VAL(tcl_cv_langinfo_h, [ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[nl_langinfo(CODESET);]])], [tcl_cv_langinfo_h=yes],[tcl_cv_langinfo_h=no])]) AC_MSG_RESULT([$tcl_cv_langinfo_h]) if test $tcl_cv_langinfo_h = yes; then AC_DEFINE(HAVE_LANGINFO, 1, [Do we have nl_langinfo()?]) fi else AC_MSG_RESULT([$langinfo_ok]) fi ]) #-------------------------------------------------------------------- # TEA_CONFIG_SYSTEM # # Determine what the system is (some things cannot be easily checked # on a feature-driven basis, alas). This can usually be done via the # "uname" command. # # Arguments: # none # # Results: # Defines the following var: # # system - System/platform/version identification code. # #-------------------------------------------------------------------- AC_DEFUN([TEA_CONFIG_SYSTEM], [ AC_CACHE_CHECK([system version], tcl_cv_sys_version, [ # TEA specific: if test "${TEA_PLATFORM}" = "windows" ; then tcl_cv_sys_version=windows else tcl_cv_sys_version=`uname -s`-`uname -r` if test "$?" -ne 0 ; then AC_MSG_WARN([can't find uname command]) tcl_cv_sys_version=unknown else if test "`uname -s`" = "AIX" ; then tcl_cv_sys_version=AIX-`uname -v`.`uname -r` fi if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then tcl_cv_sys_version=NetBSD-Debian fi fi fi ]) system=$tcl_cv_sys_version ]) #-------------------------------------------------------------------- # TEA_CONFIG_CFLAGS # # Try to determine the proper flags to pass to the compiler # for building shared libraries and other such nonsense. # # Arguments: # none # # Results: # # Defines and substitutes the following vars: # # DL_OBJS, DL_LIBS - removed for TEA, only needed by core. # LDFLAGS - Flags to pass to the compiler when linking object # files into an executable application binary such # as tclsh. # LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib", # that tell the run-time dynamic linker where to look # for shared libraries such as libtcl.so. Depends on # the variable LIB_RUNTIME_DIR in the Makefile. Could # be the same as CC_SEARCH_FLAGS if ${CC} is used to link. # CC_SEARCH_FLAGS-Flags to pass to ${CC}, such as "-Wl,-rpath,/usr/local/tcl/lib", # that tell the run-time dynamic linker where to look # for shared libraries such as libtcl.so. Depends on # the variable LIB_RUNTIME_DIR in the Makefile. # SHLIB_CFLAGS - Flags to pass to cc when compiling the components # of a shared library (may request position-independent # code, among other things). # SHLIB_LD - Base command to use for combining object files # into a shared library. # SHLIB_LD_LIBS - Dependent libraries for the linker to scan when # creating shared libraries. This symbol typically # goes at the end of the "ld" commands that build # shared libraries. The value of the symbol defaults to # "${LIBS}" if all of the dependent libraries should # be specified when creating a shared library. If # dependent libraries should not be specified (as on # SunOS 4.x, where they cause the link to fail, or in # general if Tcl and Tk aren't themselves shared # libraries), then this symbol has an empty string # as its value. # SHLIB_SUFFIX - Suffix to use for the names of dynamically loadable # extensions. An empty string means we don't know how # to use shared libraries on this platform. # LIB_SUFFIX - Specifies everything that comes after the "libfoo" # in a static or shared library name, using the $PACKAGE_VERSION variable # to put the version in the right place. This is used # by platforms that need non-standard library names. # Examples: ${PACKAGE_VERSION}.so.1.1 on NetBSD, since it needs # to have a version after the .so, and ${PACKAGE_VERSION}.a # on AIX, since a shared library needs to have # a .a extension whereas shared objects for loadable # extensions have a .so extension. Defaults to # ${PACKAGE_VERSION}${SHLIB_SUFFIX}. # CFLAGS_DEBUG - # Flags used when running the compiler in debug mode # CFLAGS_OPTIMIZE - # Flags used when running the compiler in optimize mode # CFLAGS - Additional CFLAGS added as necessary (usually 64-bit) #-------------------------------------------------------------------- AC_DEFUN([TEA_CONFIG_CFLAGS], [ dnl TEA specific: Make sure we are initialized AC_REQUIRE([TEA_INIT]) # Step 0.a: Enable 64 bit support? AC_MSG_CHECKING([if 64bit support is requested]) AC_ARG_ENABLE(64bit, AS_HELP_STRING([--enable-64bit], [enable 64bit support (default: off)]), [do64bit=$enableval], [do64bit=no]) AC_MSG_RESULT([$do64bit]) # Step 0.b: Enable Solaris 64 bit VIS support? AC_MSG_CHECKING([if 64bit Sparc VIS support is requested]) AC_ARG_ENABLE(64bit-vis, AS_HELP_STRING([--enable-64bit-vis], [enable 64bit Sparc VIS support (default: off)]), [do64bitVIS=$enableval], [do64bitVIS=no]) AC_MSG_RESULT([$do64bitVIS]) # Force 64bit on with VIS AS_IF([test "$do64bitVIS" = "yes"], [do64bit=yes]) # Step 0.c: Check if visibility support is available. Do this here so # that platform specific alternatives can be used below if this fails. AC_CACHE_CHECK([if compiler supports visibility "hidden"], tcl_cv_cc_visibility_hidden, [ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" AC_LINK_IFELSE([AC_LANG_PROGRAM([[ extern __attribute__((__visibility__("hidden"))) void f(void); void f(void) {}]], [[f();]])],[tcl_cv_cc_visibility_hidden=yes], [tcl_cv_cc_visibility_hidden=no]) CFLAGS=$hold_cflags]) AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [ AC_DEFINE(MODULE_SCOPE, [extern __attribute__((__visibility__("hidden")))], [Compiler support for module scope symbols]) AC_DEFINE(HAVE_HIDDEN, [1], [Compiler support for module scope symbols]) ]) # Step 0.d: Disable -rpath support? AC_MSG_CHECKING([if rpath support is requested]) AC_ARG_ENABLE(rpath, AS_HELP_STRING([--disable-rpath], [disable rpath support (default: on)]), [doRpath=$enableval], [doRpath=yes]) AC_MSG_RESULT([$doRpath]) # Set the variable "system" to hold the name and version number # for the system. TEA_CONFIG_SYSTEM # Require ranlib early so we can override it in special cases below. AC_REQUIRE([AC_PROG_RANLIB]) # Set configuration options based on system name and version. # This is similar to Tcl's unix/tcl.m4 except that we've added a # "windows" case and removed some core-only vars. do64bit_ok=no # default to '{$LIBS}' and set to "" on per-platform necessary basis SHLIB_LD_LIBS='${LIBS}' # When ld needs options to work in 64-bit mode, put them in # LDFLAGS_ARCH so they eventually end up in LDFLAGS even if [load] # is disabled by the user. [Bug 1016796] LDFLAGS_ARCH="" UNSHARED_LIB_SUFFIX="" # TEA specific: use PACKAGE_VERSION instead of VERSION TCL_TRIM_DOTS='`echo ${PACKAGE_VERSION} | tr -d .`' ECHO_VERSION='`echo ${PACKAGE_VERSION}`' TCL_LIB_VERSIONS_OK=ok CFLAGS_DEBUG=-g AS_IF([test "$GCC" = yes], [ CFLAGS_OPTIMIZE=-O2 CFLAGS_WARNING="-Wall" ], [ CFLAGS_OPTIMIZE=-O CFLAGS_WARNING="" ]) AC_CHECK_TOOL(AR, ar) STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" AS_IF([test "x$SHLIB_VERSION" = x],[SHLIB_VERSION=""],[SHLIB_VERSION=".$SHLIB_VERSION"]) case $system in # TEA specific: windows) MACHINE="X86" if test "$do64bit" != "no" ; then case "$do64bit" in amd64|x64|yes) MACHINE="AMD64" ; # default to AMD64 64-bit build ;; arm64|aarch64) MACHINE="ARM64" ;; ia64) MACHINE="IA64" ;; esac fi if test "$GCC" != "yes" ; then if test "${SHARED_BUILD}" = "0" ; then runtime=-MT else runtime=-MD fi case "x`echo \${VisualStudioVersion}`" in x1[[4-9]]*) lflags="${lflags} -nodefaultlib:libucrt.lib" TEA_ADD_LIBS([ucrt.lib]) ;; *) ;; esac if test "$do64bit" != "no" ; then CC="cl.exe" RC="rc.exe" lflags="${lflags} -nologo -MACHINE:${MACHINE} " LINKBIN="link.exe" CFLAGS_DEBUG="-nologo -Zi -Od -W3 ${runtime}d" CFLAGS_OPTIMIZE="-nologo -O2 -W2 ${runtime}" # Avoid 'unresolved external symbol __security_cookie' # errors, c.f. http://support.microsoft.com/?id=894573 TEA_ADD_LIBS([bufferoverflowU.lib]) else RC="rc" lflags="${lflags} -nologo" LINKBIN="link" CFLAGS_DEBUG="-nologo -Z7 -Od -W3 -WX ${runtime}d" CFLAGS_OPTIMIZE="-nologo -O2 -W2 ${runtime}" fi fi if test "$GCC" = "yes"; then # mingw gcc mode AC_CHECK_TOOL(RC, windres) CFLAGS_DEBUG="-g" CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" SHLIB_LD='${CC} -shared' UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' LDFLAGS_CONSOLE="-wl,--subsystem,console ${lflags}" LDFLAGS_WINDOW="-wl,--subsystem,windows ${lflags}" AC_CACHE_CHECK(for cross-compile version of gcc, ac_cv_cross, AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ #ifdef _WIN32 #error cross-compiler #endif ]], [[]])], [ac_cv_cross=yes], [ac_cv_cross=no]) ) if test "$ac_cv_cross" = "yes"; then case "$do64bit" in amd64|x64|yes) CC="x86_64-w64-mingw32-${CC}" LD="x86_64-w64-mingw32-ld" AR="x86_64-w64-mingw32-ar" RANLIB="x86_64-w64-mingw32-ranlib" RC="x86_64-w64-mingw32-windres" ;; arm64|aarch64) CC="aarch64-w64-mingw32-clang" LD="aarch64-w64-mingw32-ld" AR="aarch64-w64-mingw32-ar" RANLIB="aarch64-w64-mingw32-ranlib" RC="aarch64-w64-mingw32-windres" ;; *) CC="i686-w64-mingw32-${CC}" LD="i686-w64-mingw32-ld" AR="i686-w64-mingw32-ar" RANLIB="i686-w64-mingw32-ranlib" RC="i686-w64-mingw32-windres" ;; esac fi else SHLIB_LD="${LINKBIN} -dll ${lflags}" # link -lib only works when -lib is the first arg STLIB_LD="${LINKBIN} -lib ${lflags}" UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.lib' PATHTYPE=-w # For information on what debugtype is most useful, see: # http://msdn.microsoft.com/library/en-us/dnvc60/html/gendepdebug.asp # and also # http://msdn2.microsoft.com/en-us/library/y0zzbyt4%28VS.80%29.aspx # This essentially turns it all on. LDFLAGS_DEBUG="-debug -debugtype:cv" LDFLAGS_OPTIMIZE="-release" LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" fi SHLIB_SUFFIX=".dll" SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.dll' TCL_LIB_VERSIONS_OK=nodots ;; AIX-*) AS_IF([test "$GCC" != "yes"], [ # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r|*_r\ *) # ok ... ;; *) # Make sure only first arg gets _r CC=`echo "$CC" | sed -e 's/^\([[^ ]]*\)/\1_r/'` ;; esac AC_MSG_RESULT([Using $CC for compiling with threads]) ]) LIBS="$LIBS -lc" SHLIB_CFLAGS="" SHLIB_SUFFIX=".so" LD_LIBRARY_PATH_VAR="LIBPATH" # Check to enable 64-bit flags for compiler/linker AS_IF([test "$do64bit" = yes], [ AS_IF([test "$GCC" = yes], [ AC_MSG_WARN([64bit mode not supported with GCC on $system]) ], [ do64bit_ok=yes CFLAGS="$CFLAGS -q64" LDFLAGS_ARCH="-q64" RANLIB="${RANLIB} -X64" AR="${AR} -X64" SHLIB_LD_FLAGS="-b64" ]) ]) AS_IF([test "`uname -m`" = ia64], [ # AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC SHLIB_LD="/usr/ccs/bin/ld -G -z text" AS_IF([test "$GCC" = yes], [ CC_SEARCH_FLAGS='"-Wl,-R,${LIB_RUNTIME_DIR}"' ], [ CC_SEARCH_FLAGS='"-R${LIB_RUNTIME_DIR}"' ]) LD_SEARCH_FLAGS='-R "${LIB_RUNTIME_DIR}"' ], [ AS_IF([test "$GCC" = yes], [ SHLIB_LD='${CC} -shared -Wl,-bexpall' ], [ SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bexpall -H512 -T512 -bnoentry" LDFLAGS="$LDFLAGS -brtl" ]) SHLIB_LD="${SHLIB_LD} ${SHLIB_LD_FLAGS}" CC_SEARCH_FLAGS='"-L${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ]) ;; BeOS*) SHLIB_CFLAGS="-fPIC" SHLIB_LD='${CC} -nostart' SHLIB_SUFFIX=".so" #----------------------------------------------------------- # Check for inet_ntoa in -lbind, for BeOS (which also needs # -lsocket, even if the network functions are in -lnet which # is always linked to, for compatibility. #----------------------------------------------------------- AC_CHECK_LIB(bind, inet_ntoa, [LIBS="$LIBS -lbind -lsocket"]) ;; BSD/OS-2.1*|BSD/OS-3*) SHLIB_CFLAGS="" SHLIB_LD="shlicc -r" SHLIB_SUFFIX=".so" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; BSD/OS-4.*) SHLIB_CFLAGS="-export-dynamic -fPIC" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".so" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; CYGWIN_*) SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$[@].a" EXEEXT=".exe" do64bit_ok=yes CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; dgux*) SHLIB_CFLAGS="-K PIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' AC_CHECK_LIB(network, inet_ntoa, [LIBS="$LIBS -lnetwork"]) ;; HP-UX-*.11.*) # Use updated header definitions where possible AC_DEFINE(_XOPEN_SOURCE_EXTENDED, 1, [Do we want to use the XOPEN network library?]) # TEA specific: Needed by Tcl, but not most extensions #AC_DEFINE(_XOPEN_SOURCE, 1, [Do we want to use the XOPEN network library?]) #LIBS="$LIBS -lxnet" # Use the XOPEN network library AS_IF([test "`uname -m`" = ia64], [ SHLIB_SUFFIX=".so" ], [ SHLIB_SUFFIX=".sl" ]) AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) AS_IF([test "$tcl_ok" = yes], [ SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='"-Wl,+s,+b,${LIB_RUNTIME_DIR}:."' LD_SEARCH_FLAGS='+s +b "${LIB_RUNTIME_DIR}:."' LD_LIBRARY_PATH_VAR="SHLIB_PATH" ]) AS_IF([test "$GCC" = yes], [ SHLIB_LD='${CC} -shared' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ], [ CFLAGS="$CFLAGS -z" ]) # Check to enable 64-bit flags for compiler/linker AS_IF([test "$do64bit" = "yes"], [ AS_IF([test "$GCC" = yes], [ case `${CC} -dumpmachine` in hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD='${CC} -shared' AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) AC_MSG_WARN([64bit mode not supported with GCC on $system]) ;; esac ], [ do64bit_ok=yes CFLAGS="$CFLAGS +DD64" LDFLAGS_ARCH="+DD64" ]) ]) ;; HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) SHLIB_SUFFIX=".sl" AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) AS_IF([test "$tcl_ok" = yes], [ SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS="" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='"-Wl,+s,+b,${LIB_RUNTIME_DIR}:."' LD_SEARCH_FLAGS='+s +b "${LIB_RUNTIME_DIR}:."' LD_LIBRARY_PATH_VAR="SHLIB_PATH" ]) ;; IRIX-5.*) SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_SUFFIX=".so" AC_LIBOBJ(mkstemp) AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath "${LIB_RUNTIME_DIR}"']) ;; IRIX-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_SUFFIX=".so" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath "${LIB_RUNTIME_DIR}"']) AS_IF([test "$GCC" = yes], [ CFLAGS="$CFLAGS -mabi=n32" LDFLAGS="$LDFLAGS -mabi=n32" ], [ case $system in IRIX-6.3) # Use to build 6.2 compatible binaries on 6.3. CFLAGS="$CFLAGS -n32 -D_OLD_TERMIOS" ;; *) CFLAGS="$CFLAGS -n32" ;; esac LDFLAGS="$LDFLAGS -n32" ]) ;; IRIX64-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_SUFFIX=".so" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath "${LIB_RUNTIME_DIR}"']) # Check to enable 64-bit flags for compiler/linker AS_IF([test "$do64bit" = yes], [ AS_IF([test "$GCC" = yes], [ AC_MSG_WARN([64bit mode not supported by gcc]) ], [ do64bit_ok=yes SHLIB_LD="ld -64 -shared -rdata_shared" CFLAGS="$CFLAGS -64" LDFLAGS_ARCH="-64" ]) ]) ;; Linux*|GNU*|NetBSD-Debian|DragonFly-*|FreeBSD-*) SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" # TEA specific: CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" # TEA specific: use LDFLAGS_DEFAULT instead of LDFLAGS SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS_DEFAULT} -shared' LDFLAGS="$LDFLAGS -Wl,--export-dynamic" case $system in DragonFly-*|FreeBSD-*) AS_IF([test "${TCL_THREADS}" = "1"], [ # The -pthread needs to go in the LDFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS $PTHREAD_CFLAGS" LDFLAGS="$LDFLAGS $PTHREAD_LIBS"]) ;; esac AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} AS_IF([test "`uname -m`" = "alpha"], [CFLAGS="$CFLAGS -mieee"]) AS_IF([test $do64bit = yes], [ AC_CACHE_CHECK([if compiler accepts -m64 flag], tcl_cv_cc_m64, [ hold_cflags=$CFLAGS CFLAGS="$CFLAGS -m64" AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[]])], [tcl_cv_cc_m64=yes],[tcl_cv_cc_m64=no]) CFLAGS=$hold_cflags]) AS_IF([test $tcl_cv_cc_m64 = yes], [ CFLAGS="$CFLAGS -m64" do64bit_ok=yes ]) ]) # The combo of gcc + glibc has a bug related to inlining of # functions like strtod(). The -fno-builtin flag should address # this problem but it does not work. The -fno-inline flag is kind # of overkill but it works. Disable inlining only when one of the # files in compat/*.c is being linked in. AS_IF([test x"${USE_COMPAT}" != x],[CFLAGS="$CFLAGS -fno-inline"]) ;; Lynx*) SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" CFLAGS_OPTIMIZE=-02 SHLIB_LD='${CC} -shared' LD_FLAGS="-Wl,--export-dynamic" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"']) ;; OpenBSD-*) arch=`arch -s` case "$arch" in alpha|sparc64) SHLIB_CFLAGS="-fPIC" ;; *) SHLIB_CFLAGS="-fpic" ;; esac SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so${SHLIB_VERSION}' LDFLAGS="$LDFLAGS -Wl,-export-dynamic" CFLAGS_OPTIMIZE="-O2" # On OpenBSD: Compile with -pthread # Don't link with -lpthread LIBS=`echo $LIBS | sed s/-lpthread//` CFLAGS="$CFLAGS -pthread" # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" LDFLAGS="$LDFLAGS -export-dynamic" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} # The -pthread needs to go in the CFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" ;; Darwin-*) CFLAGS_OPTIMIZE="-Os" SHLIB_CFLAGS="-fno-common" # To avoid discrepancies between what headers configure sees during # preprocessing tests and compiling tests, move any -isysroot and # -mmacosx-version-min flags from CFLAGS to CPPFLAGS: CPPFLAGS="${CPPFLAGS} `echo " ${CFLAGS}" | \ awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ if ([$]i~/^(isysroot|mmacosx-version-min)/) print "-"[$]i}'`" CFLAGS="`echo " ${CFLAGS}" | \ awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ if (!([$]i~/^(isysroot|mmacosx-version-min)/)) print "-"[$]i}'`" AS_IF([test $do64bit = yes], [ case `arch` in ppc) AC_CACHE_CHECK([if compiler accepts -arch ppc64 flag], tcl_cv_cc_arch_ppc64, [ hold_cflags=$CFLAGS CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[]])], [tcl_cv_cc_arch_ppc64=yes],[tcl_cv_cc_arch_ppc64=no]) CFLAGS=$hold_cflags]) AS_IF([test $tcl_cv_cc_arch_ppc64 = yes], [ CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" do64bit_ok=yes ]);; i386) AC_CACHE_CHECK([if compiler accepts -arch x86_64 flag], tcl_cv_cc_arch_x86_64, [ hold_cflags=$CFLAGS CFLAGS="$CFLAGS -arch x86_64" AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[]])], [tcl_cv_cc_arch_x86_64=yes],[tcl_cv_cc_arch_x86_64=no]) CFLAGS=$hold_cflags]) AS_IF([test $tcl_cv_cc_arch_x86_64 = yes], [ CFLAGS="$CFLAGS -arch x86_64" do64bit_ok=yes ]);; *) AC_MSG_WARN([Don't know how enable 64-bit on architecture `arch`]);; esac ], [ # Check for combined 32-bit and 64-bit fat build AS_IF([echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64) ' \ && echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '], [ fat_32_64=yes]) ]) # TEA specific: use LDFLAGS_DEFAULT instead of LDFLAGS SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS_DEFAULT}' # TEA specific: link shlib with current and compatibility version flags vers=`echo ${PACKAGE_VERSION} | sed -e 's/^\([[0-9]]\{1,5\}\)\(\(\.[[0-9]]\{1,3\}\)\{0,2\}\).*$/\1\2/p' -e d` SHLIB_LD="${SHLIB_LD} -current_version ${vers:-0} -compatibility_version ${vers:-0}" SHLIB_SUFFIX=".dylib" LDFLAGS="$LDFLAGS -headerpad_max_install_names" AC_CACHE_CHECK([if ld accepts -search_paths_first flag], tcl_cv_ld_search_paths_first, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-search_paths_first" AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[int i;]])], [tcl_cv_ld_search_paths_first=yes],[tcl_cv_ld_search_paths_first=no]) LDFLAGS=$hold_ldflags]) AS_IF([test $tcl_cv_ld_search_paths_first = yes], [ LDFLAGS="$LDFLAGS -Wl,-search_paths_first" ]) AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [ AC_DEFINE(MODULE_SCOPE, [__private_extern__], [Compiler support for module scope symbols]) tcl_cv_cc_visibility_hidden=yes ]) CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" # TEA specific: for combined 32 & 64 bit fat builds of Tk # extensions, verify that 64-bit build is possible. AS_IF([test "$fat_32_64" = yes && test -n "${TK_BIN_DIR}"], [ AS_IF([test "${TEA_WINDOWINGSYSTEM}" = x11], [ AC_CACHE_CHECK([for 64-bit X11], tcl_cv_lib_x11_64, [ for v in CFLAGS CPPFLAGS LDFLAGS; do eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"' done CPPFLAGS="$CPPFLAGS -I/usr/X11R6/include" LDFLAGS="$LDFLAGS -L/usr/X11R6/lib -lX11" AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include ]], [[XrmInitialize();]])], [tcl_cv_lib_x11_64=yes],[tcl_cv_lib_x11_64=no]) for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done]) ]) AS_IF([test "${TEA_WINDOWINGSYSTEM}" = aqua], [ AC_CACHE_CHECK([for 64-bit Tk], tcl_cv_lib_tk_64, [ for v in CFLAGS CPPFLAGS LDFLAGS; do eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"' done CPPFLAGS="$CPPFLAGS -DUSE_TCL_STUBS=1 -DUSE_TK_STUBS=1 ${TCL_INCLUDES} ${TK_INCLUDES}" LDFLAGS="$LDFLAGS ${TCL_STUB_LIB_SPEC} ${TK_STUB_LIB_SPEC}" AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include ]], [[Tk_InitStubs(NULL, "", 0);]])], [tcl_cv_lib_tk_64=yes],[tcl_cv_lib_tk_64=no]) for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done]) ]) # remove 64-bit arch flags from CFLAGS et al. if configuration # does not support 64-bit. AS_IF([test "$tcl_cv_lib_tk_64" = no -o "$tcl_cv_lib_x11_64" = no], [ AC_MSG_NOTICE([Removing 64-bit architectures from compiler & linker flags]) for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"' done]) ]) ;; OS/390-*) CFLAGS_OPTIMIZE="" # Optimizer is buggy AC_DEFINE(_OE_SOCKETS, 1, # needed in sys/socket.h [Should OS/390 do the right thing with sockets?]) ;; OSF1-V*) # Digital OSF/1 SHLIB_CFLAGS="" AS_IF([test "$SHARED_BUILD" = 1], [ SHLIB_LD='ld -shared -expect_unresolved "*"' ], [ SHLIB_LD='ld -non_shared -expect_unresolved "*"' ]) SHLIB_SUFFIX=".so" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) AS_IF([test "$GCC" = yes], [CFLAGS="$CFLAGS -mieee"], [ CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"]) # see pthread_intro(3) for pthread support on osf1, k.furukawa CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" LIBS=`echo $LIBS | sed s/-lpthreads//` AS_IF([test "$GCC" = yes], [ LIBS="$LIBS -lpthread -lmach -lexc" ], [ CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" ]) ;; QNX-6*) # QNX RTP # This may work for all QNX, but it was only reported for v6. SHLIB_CFLAGS="-fPIC" SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SCO_SV-3.2*) AS_IF([test "$GCC" = yes], [ SHLIB_CFLAGS="-fPIC -melf" LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" ], [ SHLIB_CFLAGS="-Kpic -belf" LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" ]) SHLIB_LD="ld -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SunOS-5.[[0-6]]) # Careful to not let 5.10+ fall into this case # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) SHLIB_CFLAGS="-KPIC" SHLIB_SUFFIX=".so" AS_IF([test "$GCC" = yes], [ SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='"-Wl,-R,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ], [ SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-R "${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ]) ;; SunOS-5*) # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) SHLIB_CFLAGS="-KPIC" # Check to enable 64-bit flags for compiler/linker AS_IF([test "$do64bit" = yes], [ arch=`isainfo` AS_IF([test "$arch" = "sparcv9 sparc"], [ AS_IF([test "$GCC" = yes], [ AS_IF([test "`${CC} -dumpversion | awk -F. '{print [$]1}'`" -lt 3], [ AC_MSG_WARN([64bit mode not supported with GCC < 3.2 on $system]) ], [ do64bit_ok=yes CFLAGS="$CFLAGS -m64 -mcpu=v9" LDFLAGS="$LDFLAGS -m64 -mcpu=v9" SHLIB_CFLAGS="-fPIC" ]) ], [ do64bit_ok=yes AS_IF([test "$do64bitVIS" = yes], [ CFLAGS="$CFLAGS -xarch=v9a" LDFLAGS_ARCH="-xarch=v9a" ], [ CFLAGS="$CFLAGS -xarch=v9" LDFLAGS_ARCH="-xarch=v9" ]) # Solaris 64 uses this as well #LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64" ]) ], [AS_IF([test "$arch" = "amd64 i386"], [ AS_IF([test "$GCC" = yes], [ case $system in SunOS-5.1[[1-9]]*|SunOS-5.[[2-9]][[0-9]]*) do64bit_ok=yes CFLAGS="$CFLAGS -m64" LDFLAGS="$LDFLAGS -m64";; *) AC_MSG_WARN([64bit mode not supported with GCC on $system]);; esac ], [ do64bit_ok=yes case $system in SunOS-5.1[[1-9]]*|SunOS-5.[[2-9]][[0-9]]*) CFLAGS="$CFLAGS -m64" LDFLAGS="$LDFLAGS -m64";; *) CFLAGS="$CFLAGS -xarch=amd64" LDFLAGS="$LDFLAGS -xarch=amd64";; esac ]) ], [AC_MSG_WARN([64bit mode not supported for $arch])])]) ]) SHLIB_SUFFIX=".so" AS_IF([test "$GCC" = yes], [ SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='"-Wl,-R,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} AS_IF([test "$do64bit_ok" = yes], [ AS_IF([test "$arch" = "sparcv9 sparc"], [ # We need to specify -static-libgcc or we need to # add the path to the sparv9 libgcc. # JH: static-libgcc is necessary for core Tcl, but may # not be necessary for extensions. SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" # for finding sparcv9 libgcc, get the regular libgcc # path, remove so name and append 'sparcv9' #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" ], [AS_IF([test "$arch" = "amd64 i386"], [ # JH: static-libgcc is necessary for core Tcl, but may # not be necessary for extensions. SHLIB_LD="$SHLIB_LD -m64 -static-libgcc" ])]) ]) ], [ case $system in SunOS-5.[[1-9]][[0-9]]*) # TEA specific: use LDFLAGS_DEFAULT instead of LDFLAGS SHLIB_LD='${CC} -G -z text ${LDFLAGS_DEFAULT}';; *) SHLIB_LD='/usr/ccs/bin/ld -G -z text';; esac CC_SEARCH_FLAGS='"-Wl,-R,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-R "${LIB_RUNTIME_DIR}"' ]) ;; UNIX_SV* | UnixWare-5*) SHLIB_CFLAGS="-KPIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers # that don't grok the -Bexport option. Test that it does. AC_CACHE_CHECK([for ld accepts -Bexport flag], tcl_cv_ld_Bexport, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-Bexport" AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[int i;]])], [tcl_cv_ld_Bexport=yes],[tcl_cv_ld_Bexport=no]) LDFLAGS=$hold_ldflags]) AS_IF([test $tcl_cv_ld_Bexport = yes], [ LDFLAGS="$LDFLAGS -Wl,-Bexport" ]) CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; esac AS_IF([test "$do64bit" = yes -a "$do64bit_ok" = no], [ AC_MSG_WARN([64bit support being disabled -- don't know magic for this platform]) ]) dnl # Add any CPPFLAGS set in the environment to our CFLAGS, but delay doing so dnl # until the end of configure, as configure's compile and link tests use dnl # both CPPFLAGS and CFLAGS (unlike our compile and link) but configure's dnl # preprocessing tests use only CPPFLAGS. AC_CONFIG_COMMANDS_PRE([CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS=""]) # Add in the arch flags late to ensure it wasn't removed. # Not necessary in TEA, but this is aligned with core LDFLAGS="$LDFLAGS $LDFLAGS_ARCH" # If we're running gcc, then change the C flags for compiling shared # libraries to the right flags for gcc, instead of those for the # standard manufacturer compiler. AS_IF([test "$GCC" = yes], [ case $system in AIX-*) ;; BSD/OS*) ;; CYGWIN_*|MINGW32_*|MINGW64_*|MSYS_*) ;; IRIX*) ;; NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;; Darwin-*) ;; SCO_SV-3.2*) ;; windows) ;; *) SHLIB_CFLAGS="-fPIC" ;; esac]) AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [ AC_DEFINE(MODULE_SCOPE, [extern], [No Compiler support for module scope symbols]) ]) AS_IF([test "$SHARED_LIB_SUFFIX" = ""], [ # TEA specific: use PACKAGE_VERSION instead of VERSION SHARED_LIB_SUFFIX='${PACKAGE_VERSION}${SHLIB_SUFFIX}']) AS_IF([test "$UNSHARED_LIB_SUFFIX" = ""], [ # TEA specific: use PACKAGE_VERSION instead of VERSION UNSHARED_LIB_SUFFIX='${PACKAGE_VERSION}.a']) if test "${GCC}" = "yes" -a ${SHLIB_SUFFIX} = ".dll"; then AC_CACHE_CHECK(for SEH support in compiler, tcl_cv_seh, AC_RUN_IFELSE([AC_LANG_SOURCE([[ #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN int main(int argc, char** argv) { int a, b = 0; __try { a = 666 / b; } __except (EXCEPTION_EXECUTE_HANDLER) { return 0; } return 1; } ]])], [tcl_cv_seh=yes], [tcl_cv_seh=no], [tcl_cv_seh=no]) ) if test "$tcl_cv_seh" = "no" ; then AC_DEFINE(HAVE_NO_SEH, 1, [Defined when mingw does not support SEH]) fi # # Check to see if the excpt.h include file provided contains the # definition for EXCEPTION_DISPOSITION; if not, which is the case # with Cygwin's version as of 2002-04-10, define it to be int, # sufficient for getting the current code to work. # AC_CACHE_CHECK(for EXCEPTION_DISPOSITION support in include files, tcl_cv_eh_disposition, AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ # define WIN32_LEAN_AND_MEAN # include # undef WIN32_LEAN_AND_MEAN ]], [[ EXCEPTION_DISPOSITION x; ]])], [tcl_cv_eh_disposition=yes], [tcl_cv_eh_disposition=no]) ) if test "$tcl_cv_eh_disposition" = "no" ; then AC_DEFINE(EXCEPTION_DISPOSITION, int, [Defined when cygwin/mingw does not support EXCEPTION DISPOSITION]) fi # Check to see if winnt.h defines CHAR, SHORT, and LONG # even if VOID has already been #defined. The win32api # used by mingw and cygwin is known to do this. AC_CACHE_CHECK(for winnt.h that ignores VOID define, tcl_cv_winnt_ignore_void, AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ #define VOID void #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN ]], [[ CHAR c; SHORT s; LONG l; ]])], [tcl_cv_winnt_ignore_void=yes], [tcl_cv_winnt_ignore_void=no]) ) if test "$tcl_cv_winnt_ignore_void" = "yes" ; then AC_DEFINE(HAVE_WINNT_IGNORE_VOID, 1, [Defined when cygwin/mingw ignores VOID define in winnt.h]) fi fi # See if the compiler supports casting to a union type. # This is used to stop gcc from printing a compiler # warning when initializing a union member. AC_CACHE_CHECK(for cast to union support, tcl_cv_cast_to_union, AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[ union foo { int i; double d; }; union foo f = (union foo) (int) 0; ]])], [tcl_cv_cast_to_union=yes], [tcl_cv_cast_to_union=no]) ) if test "$tcl_cv_cast_to_union" = "yes"; then AC_DEFINE(HAVE_CAST_TO_UNION, 1, [Defined when compiler supports casting to union type.]) fi AC_CHECK_HEADER(stdbool.h, [AC_DEFINE(HAVE_STDBOOL_H, 1, [Do we have ?])],) AC_SUBST(CFLAGS_DEBUG) AC_SUBST(CFLAGS_OPTIMIZE) AC_SUBST(CFLAGS_WARNING) AC_SUBST(LDFLAGS_DEBUG) AC_SUBST(LDFLAGS_OPTIMIZE) AC_SUBST(STLIB_LD) AC_SUBST(SHLIB_LD) AC_SUBST(SHLIB_LD_LIBS) AC_SUBST(SHLIB_CFLAGS) AC_SUBST(LD_LIBRARY_PATH_VAR) # These must be called after we do the basic CFLAGS checks and # verify any possible 64-bit or similar switches are necessary TEA_TCL_EARLY_FLAGS TEA_TCL_64BIT_FLAGS ]) #-------------------------------------------------------------------- # TEA_SERIAL_PORT # # Determine which interface to use to talk to the serial port. # Note that #include lines must begin in leftmost column for # some compilers to recognize them as preprocessor directives, # and some build environments have stdin not pointing at a # pseudo-terminal (usually /dev/null instead.) # # Arguments: # none # # Results: # # Defines only one of the following vars: # HAVE_SYS_MODEM_H # USE_TERMIOS # USE_TERMIO # USE_SGTTY #-------------------------------------------------------------------- AC_DEFUN([TEA_SERIAL_PORT], [ AC_CHECK_HEADERS(sys/modem.h) AC_CACHE_CHECK([termios vs. termio vs. sgtty], tcl_cv_api_serial, [ AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include int main() { struct termios t; if (tcgetattr(0, &t) == 0) { cfsetospeed(&t, 0); t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB; return 0; } return 1; }]])],[tcl_cv_api_serial=termios],[tcl_cv_api_serial=no],[tcl_cv_api_serial=no]) if test $tcl_cv_api_serial = no ; then AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include int main() { struct termio t; if (ioctl(0, TCGETA, &t) == 0) { t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB; return 0; } return 1; }]])],[tcl_cv_api_serial=termio],[tcl_cv_api_serial=no],[tcl_cv_api_serial=no]) fi if test $tcl_cv_api_serial = no ; then AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include int main() { struct sgttyb t; if (ioctl(0, TIOCGETP, &t) == 0) { t.sg_ospeed = 0; t.sg_flags |= ODDP | EVENP | RAW; return 0; } return 1; }]])],[tcl_cv_api_serial=sgtty],[tcl_cv_api_serial=no],[tcl_cv_api_serial=no]) fi if test $tcl_cv_api_serial = no ; then AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include #include int main() { struct termios t; if (tcgetattr(0, &t) == 0 || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { cfsetospeed(&t, 0); t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB; return 0; } return 1; }]])],[tcl_cv_api_serial=termios],[tcl_cv_api_serial=no],[tcl_cv_api_serial=no]) fi if test $tcl_cv_api_serial = no; then AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include #include int main() { struct termio t; if (ioctl(0, TCGETA, &t) == 0 || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB; return 0; } return 1; }]])],[tcl_cv_api_serial=termio],[tcl_cv_api_serial=no],[tcl_cv_api_serial=no]) fi if test $tcl_cv_api_serial = no; then AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include #include int main() { struct sgttyb t; if (ioctl(0, TIOCGETP, &t) == 0 || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { t.sg_ospeed = 0; t.sg_flags |= ODDP | EVENP | RAW; return 0; } return 1; }]])],[tcl_cv_api_serial=sgtty],[tcl_cv_api_serial=none],[tcl_cv_api_serial=none]) fi]) case $tcl_cv_api_serial in termios) AC_DEFINE(USE_TERMIOS, 1, [Use the termios API for serial lines]);; termio) AC_DEFINE(USE_TERMIO, 1, [Use the termio API for serial lines]);; sgtty) AC_DEFINE(USE_SGTTY, 1, [Use the sgtty API for serial lines]);; esac ]) #-------------------------------------------------------------------- # TEA_PATH_X # # Locate the X11 header files and the X11 library archive. Try # the ac_path_x macro first, but if it doesn't find the X stuff # (e.g. because there's no xmkmf program) then check through # a list of possible directories. Under some conditions the # autoconf macro will return an include directory that contains # no include files, so double-check its result just to be safe. # # This should be called after TEA_CONFIG_CFLAGS as setting the # LIBS line can confuse some configure macro magic. # # Arguments: # none # # Results: # # Sets the following vars: # XINCLUDES # XLIBSW # PKG_LIBS (appends to) #-------------------------------------------------------------------- AC_DEFUN([TEA_PATH_X], [ if test "${TEA_WINDOWINGSYSTEM}" = "x11" ; then TEA_PATH_UNIX_X fi ]) AC_DEFUN([TEA_PATH_UNIX_X], [ AC_PATH_X not_really_there="" if test "$no_x" = ""; then if test "$x_includes" = ""; then AC_PREPROC_IFELSE([AC_LANG_SOURCE([[#include ]])],[],[not_really_there="yes"]) else if test ! -r $x_includes/X11/Xlib.h; then not_really_there="yes" fi fi fi if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then AC_MSG_CHECKING([for X11 header files]) found_xincludes="no" AC_PREPROC_IFELSE([AC_LANG_SOURCE([[#include ]])],[found_xincludes="yes"],[found_xincludes="no"]) if test "$found_xincludes" = "no"; then dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include" for i in $dirs ; do if test -r $i/X11/Xlib.h; then AC_MSG_RESULT([$i]) XINCLUDES=" -I$i" found_xincludes="yes" break fi done fi else if test "$x_includes" != ""; then XINCLUDES="-I$x_includes" found_xincludes="yes" fi fi if test "$found_xincludes" = "no"; then AC_MSG_RESULT([couldn't find any!]) fi if test "$no_x" = yes; then AC_MSG_CHECKING([for X11 libraries]) XLIBSW=nope dirs="/usr/unsupported/lib /usr/local/lib /usr/X386/lib /usr/X11R6/lib /usr/X11R5/lib /usr/lib/X11R5 /usr/lib/X11R4 /usr/openwin/lib /usr/X11/lib /usr/sww/X11/lib" for i in $dirs ; do if test -r $i/libX11.a -o -r $i/libX11.so -o -r $i/libX11.sl -o -r $i/libX11.dylib; then AC_MSG_RESULT([$i]) XLIBSW="-L$i -lX11" x_libraries="$i" break fi done else if test "$x_libraries" = ""; then XLIBSW=-lX11 else XLIBSW="-L$x_libraries -lX11" fi fi if test "$XLIBSW" = nope ; then AC_CHECK_LIB(Xwindow, XCreateWindow, XLIBSW=-lXwindow) fi if test "$XLIBSW" = nope ; then AC_MSG_RESULT([could not find any! Using -lX11.]) XLIBSW=-lX11 fi # TEA specific: if test x"${XLIBSW}" != x ; then PKG_LIBS="${PKG_LIBS} ${XLIBSW}" fi ]) #-------------------------------------------------------------------- # TEA_BLOCKING_STYLE # # The statements below check for systems where POSIX-style # non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. # On these systems (mostly older ones), use the old BSD-style # FIONBIO approach instead. # # Arguments: # none # # Results: # # Defines some of the following vars: # HAVE_SYS_IOCTL_H # HAVE_SYS_FILIO_H # USE_FIONBIO # O_NONBLOCK #-------------------------------------------------------------------- AC_DEFUN([TEA_BLOCKING_STYLE], [ AC_CHECK_HEADERS(sys/ioctl.h) AC_CHECK_HEADERS(sys/filio.h) TEA_CONFIG_SYSTEM AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) case $system in OSF*) AC_DEFINE(USE_FIONBIO, 1, [Should we use FIONBIO?]) AC_MSG_RESULT([FIONBIO]) ;; *) AC_MSG_RESULT([O_NONBLOCK]) ;; esac ]) #-------------------------------------------------------------------- # TEA_TIME_HANDLER # # Checks how the system deals with time.h, what time structures # are used on the system, and what fields the structures have. # # Arguments: # none # # Results: # # Defines some of the following vars: # USE_DELTA_FOR_TZ # HAVE_TM_GMTOFF # HAVE_TM_TZADJ # HAVE_TIMEZONE_VAR # #-------------------------------------------------------------------- AC_DEFUN([TEA_TIME_HANDLER], [ AC_CHECK_HEADERS(sys/time.h) AC_HEADER_TIME AC_STRUCT_TIMEZONE AC_CHECK_FUNCS(gmtime_r localtime_r mktime) AC_CACHE_CHECK([tm_tzadj in struct tm], tcl_cv_member_tm_tzadj, [ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[struct tm tm; (void)tm.tm_tzadj;]])], [tcl_cv_member_tm_tzadj=yes], [tcl_cv_member_tm_tzadj=no])]) if test $tcl_cv_member_tm_tzadj = yes ; then AC_DEFINE(HAVE_TM_TZADJ, 1, [Should we use the tm_tzadj field of struct tm?]) fi AC_CACHE_CHECK([tm_gmtoff in struct tm], tcl_cv_member_tm_gmtoff, [ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[struct tm tm; (void)tm.tm_gmtoff;]])], [tcl_cv_member_tm_gmtoff=yes], [tcl_cv_member_tm_gmtoff=no])]) if test $tcl_cv_member_tm_gmtoff = yes ; then AC_DEFINE(HAVE_TM_GMTOFF, 1, [Should we use the tm_gmtoff field of struct tm?]) fi # # Its important to include time.h in this check, as some systems # (like convex) have timezone functions, etc. # AC_CACHE_CHECK([long timezone variable], tcl_cv_timezone_long, [ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include #include ]], [[extern long timezone; timezone += 1; exit (0);]])], [tcl_cv_timezone_long=yes], [tcl_cv_timezone_long=no])]) if test $tcl_cv_timezone_long = yes ; then AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?]) else # # On some systems (eg IRIX 6.2), timezone is a time_t and not a long. # AC_CACHE_CHECK([time_t timezone variable], tcl_cv_timezone_time, [ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include #include ]], [[extern time_t timezone; timezone += 1; exit (0);]])], [tcl_cv_timezone_time=yes], [tcl_cv_timezone_time=no])]) if test $tcl_cv_timezone_time = yes ; then AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?]) fi fi ]) #-------------------------------------------------------------------- # TEA_BUGGY_STRTOD # # Under Solaris 2.4, strtod returns the wrong value for the # terminating character under some conditions. Check for this # and if the problem exists use a substitute procedure # "fixstrtod" (provided by Tcl) that corrects the error. # Also, on Compaq's Tru64 Unix 5.0, # strtod(" ") returns 0.0 instead of a failure to convert. # # Arguments: # none # # Results: # # Might defines some of the following vars: # strtod (=fixstrtod) #-------------------------------------------------------------------- AC_DEFUN([TEA_BUGGY_STRTOD], [ AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0) if test "$tcl_strtod" = 1; then AC_CACHE_CHECK([for Solaris2.4/Tru64 strtod bugs], tcl_cv_strtod_buggy,[ AC_RUN_IFELSE([AC_LANG_SOURCE([[ #include extern double strtod(); int main() { char *infString="Inf", *nanString="NaN", *spaceString=" "; char *term; double value; value = strtod(infString, &term); if ((term != infString) && (term[-1] == 0)) { exit(1); } value = strtod(nanString, &term); if ((term != nanString) && (term[-1] == 0)) { exit(1); } value = strtod(spaceString, &term); if (term == (spaceString+1)) { exit(1); } exit(0); }]])], [tcl_cv_strtod_buggy=ok], [tcl_cv_strtod_buggy=buggy], [tcl_cv_strtod_buggy=buggy])]) if test "$tcl_cv_strtod_buggy" = buggy; then AC_LIBOBJ([fixstrtod]) USE_COMPAT=1 AC_DEFINE(strtod, fixstrtod, [Do we want to use the strtod() in compat?]) fi fi ]) #-------------------------------------------------------------------- # TEA_TCL_LINK_LIBS # # Search for the libraries needed to link the Tcl shell. # Things like the math library (-lm), socket stuff (-lsocket vs. # -lnsl), zlib (-lz) and libtommath (-ltommath) are dealt with here. # # Arguments: # None. # # Results: # # Might append to the following vars: # LIBS # MATH_LIBS # # Might define the following vars: # HAVE_NET_ERRNO_H # #-------------------------------------------------------------------- AC_DEFUN([TEA_TCL_LINK_LIBS], [ #-------------------------------------------------------------------- # On a few very rare systems, all of the libm.a stuff is # already in libc.a. Set compiler flags accordingly. #-------------------------------------------------------------------- AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm") #-------------------------------------------------------------------- # Interactive UNIX requires -linet instead of -lsocket, plus it # needs net/errno.h to define the socket-related error codes. #-------------------------------------------------------------------- AC_CHECK_LIB(inet, main, [LIBS="$LIBS -linet"]) AC_CHECK_HEADER(net/errno.h, [ AC_DEFINE(HAVE_NET_ERRNO_H, 1, [Do we have ?])]) #-------------------------------------------------------------------- # Check for the existence of the -lsocket and -lnsl libraries. # The order here is important, so that they end up in the right # order in the command line generated by make. Here are some # special considerations: # 1. Use "connect" and "accept" to check for -lsocket, and # "gethostbyname" to check for -lnsl. # 2. Use each function name only once: can't redo a check because # autoconf caches the results of the last check and won't redo it. # 3. Use -lnsl and -lsocket only if they supply procedures that # aren't already present in the normal libraries. This is because # IRIX 5.2 has libraries, but they aren't needed and they're # bogus: they goof up name resolution if used. # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. # To get around this problem, check for both libraries together # if -lsocket doesn't work by itself. #-------------------------------------------------------------------- tcl_checkBoth=0 AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) if test "$tcl_checkSocket" = 1; then AC_CHECK_FUNC(setsockopt, , [AC_CHECK_LIB(socket, setsockopt, LIBS="$LIBS -lsocket", tcl_checkBoth=1)]) fi if test "$tcl_checkBoth" = 1; then tk_oldLibs=$LIBS LIBS="$LIBS -lsocket -lnsl" AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs]) fi AC_CHECK_FUNC(gethostbyname, , [AC_CHECK_LIB(nsl, gethostbyname, [LIBS="$LIBS -lnsl"])]) AC_CHECK_FUNC(mp_log_u32, , [AC_CHECK_LIB(tommath, mp_log_u32, [LIBS="$LIBS -ltommath"])]) AC_CHECK_FUNC(deflateSetHeader, , [AC_CHECK_LIB(z, deflateSetHeader, [LIBS="$LIBS -lz"])]) ]) #-------------------------------------------------------------------- # TEA_TCL_EARLY_FLAGS # # Check for what flags are needed to be passed so the correct OS # features are available. # # Arguments: # None # # Results: # # Might define the following vars: # _ISOC99_SOURCE # _FILE_OFFSET_BITS # #-------------------------------------------------------------------- AC_DEFUN([TEA_TCL_EARLY_FLAG],[ AC_CACHE_VAL([tcl_cv_flag_]translit($1,[A-Z],[a-z]), AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[$2]], [[$3]])], [tcl_cv_flag_]translit($1,[A-Z],[a-z])=no,[AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[[#define ]$1[ ]m4_default([$4],[1])[ ]$2]], [[$3]])], [tcl_cv_flag_]translit($1,[A-Z],[a-z])=yes, [tcl_cv_flag_]translit($1,[A-Z],[a-z])=no)])) if test ["x${tcl_cv_flag_]translit($1,[A-Z],[a-z])[}" = "xyes"] ; then AC_DEFINE($1, m4_default([$4],[1]), [Add the ]$1[ flag when building]) tcl_flags="$tcl_flags $1" fi ]) AC_DEFUN([TEA_TCL_EARLY_FLAGS],[ AC_MSG_CHECKING([for required early compiler flags]) tcl_flags="" TEA_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include ], [char *p = (char *)strtoll; char *q = (char *)strtoull;]) if test "${TCL_MAJOR_VERSION}" -ne 8 ; then TEA_TCL_EARLY_FLAG(_FILE_OFFSET_BITS,[#include ], [switch (0) { case 0: case (sizeof(off_t)==sizeof(long long)): ; }],64) fi if test "x${tcl_flags}" = "x" ; then AC_MSG_RESULT([none]) else AC_MSG_RESULT([${tcl_flags}]) fi ]) #-------------------------------------------------------------------- # TEA_TCL_64BIT_FLAGS # # Check for what is defined in the way of 64-bit features. # # Arguments: # None # # Results: # # Might define the following vars: # TCL_WIDE_INT_IS_LONG # TCL_WIDE_INT_TYPE # HAVE_STRUCT_DIRENT64, HAVE_DIR64 # HAVE_STRUCT_STAT64 # HAVE_TYPE_OFF64_T # _TIME_BITS # #-------------------------------------------------------------------- AC_DEFUN([TEA_TCL_64BIT_FLAGS], [ AC_MSG_CHECKING([for 64-bit integer type]) AC_CACHE_VAL(tcl_cv_type_64bit,[ tcl_cv_type_64bit=none # See if the compiler knows natively about __int64 AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[__int64 value = (__int64) 0;]])], [tcl_type_64bit=__int64],[tcl_type_64bit="long long"]) # See if we could use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[switch (0) { case 1: case (sizeof(${tcl_type_64bit})==sizeof(long)): ; }]])],[tcl_cv_type_64bit=${tcl_type_64bit}],[])]) if test "${tcl_cv_type_64bit}" = none ; then AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, [Do 'long' and 'long long' have the same size (64-bit)?]) AC_MSG_RESULT([yes]) elif test "${tcl_cv_type_64bit}" = "__int64" \ -a "${TEA_PLATFORM}" = "windows" ; then # TEA specific: We actually want to use the default tcl.h checks in # this case to handle both TCL_WIDE_INT_TYPE and TCL_LL_MODIFIER* AC_MSG_RESULT([using Tcl header defaults]) else AC_DEFINE_UNQUOTED(TCL_WIDE_INT_TYPE,${tcl_cv_type_64bit}, [What type should be used to define wide integers?]) AC_MSG_RESULT([${tcl_cv_type_64bit}]) # Now check for auxiliary declarations if test "${TCL_MAJOR_VERSION}" -ne 8 ; then AC_CACHE_CHECK([for 64-bit time_t], tcl_cv_time_t_64,[ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[switch (0) {case 0: case (sizeof(time_t)==sizeof(long long)): ;}]])], [tcl_cv_time_t_64=yes],[tcl_cv_time_t_64=no])]) if test "x${tcl_cv_time_t_64}" = "xno" ; then # Note that _TIME_BITS=64 requires _FILE_OFFSET_BITS=64 # which SC_TCL_EARLY_FLAGS has defined if necessary. AC_CACHE_CHECK([if _TIME_BITS=64 enables 64-bit time_t], tcl_cv__time_bits,[ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#define _TIME_BITS 64 #include ]], [[switch (0) {case 0: case (sizeof(time_t)==sizeof(long long)): ;}]])], [tcl_cv__time_bits=yes],[tcl_cv__time_bits=no])]) if test "x${tcl_cv__time_bits}" = "xyes" ; then AC_DEFINE(_TIME_BITS, 64, [_TIME_BITS=64 enables 64-bit time_t.]) fi fi fi AC_CACHE_CHECK([for struct dirent64], tcl_cv_struct_dirent64,[ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include #include ]], [[struct dirent64 p;]])], [tcl_cv_struct_dirent64=yes],[tcl_cv_struct_dirent64=no])]) if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then AC_DEFINE(HAVE_STRUCT_DIRENT64, 1, [Is 'struct dirent64' in ?]) fi AC_CACHE_CHECK([for DIR64], tcl_cv_DIR64,[ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include #include ]], [[struct dirent64 *p; DIR64 d = opendir64("."); p = readdir64(d); rewinddir64(d); closedir64(d);]])], [tcl_cv_DIR64=yes], [tcl_cv_DIR64=no])]) if test "x${tcl_cv_DIR64}" = "xyes" ; then AC_DEFINE(HAVE_DIR64, 1, [Is 'DIR64' in ?]) fi AC_CACHE_CHECK([for struct stat64], tcl_cv_struct_stat64,[ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[struct stat64 p; ]])], [tcl_cv_struct_stat64=yes], [tcl_cv_struct_stat64=no])]) if test "x${tcl_cv_struct_stat64}" = "xyes" ; then AC_DEFINE(HAVE_STRUCT_STAT64, 1, [Is 'struct stat64' in ?]) fi AC_CHECK_FUNCS(open64 lseek64) AC_MSG_CHECKING([for off64_t]) AC_CACHE_VAL(tcl_cv_type_off64_t,[ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[off64_t offset; ]])], [tcl_cv_type_off64_t=yes], [tcl_cv_type_off64_t=no])]) dnl Define HAVE_TYPE_OFF64_T only when the off64_t type and the dnl functions lseek64 and open64 are defined. if test "x${tcl_cv_type_off64_t}" = "xyes" && \ test "x${ac_cv_func_lseek64}" = "xyes" && \ test "x${ac_cv_func_open64}" = "xyes" ; then AC_DEFINE(HAVE_TYPE_OFF64_T, 1, [Is off64_t in ?]) AC_MSG_RESULT([yes]) else AC_MSG_RESULT([no]) fi fi ]) ## ## Here ends the standard Tcl configuration bits and starts the ## TEA specific functions ## #------------------------------------------------------------------------ # TEA_INIT -- # # Init various Tcl Extension Architecture (TEA) variables. # This should be the first called TEA_* macro. # # Arguments: # none # # Results: # # Defines and substs the following vars: # CYGPATH # EXEEXT # Defines only: # TEA_VERSION # TEA_INITED # TEA_PLATFORM (windows or unix) # # "cygpath" is used on windows to generate native path names for include # files. These variables should only be used with the compiler and linker # since they generate native path names. # # EXEEXT # Select the executable extension based on the host type. This # is a lightweight replacement for AC_EXEEXT that doesn't require # a compiler. #------------------------------------------------------------------------ AC_DEFUN([TEA_INIT], [ TEA_VERSION="3.13" AC_MSG_CHECKING([TEA configuration]) if test x"${PACKAGE_NAME}" = x ; then AC_MSG_ERROR([ The PACKAGE_NAME variable must be defined by your TEA configure.ac]) fi AC_MSG_RESULT([ok (TEA ${TEA_VERSION})]) # If the user did not set CFLAGS, set it now to keep macros # like AC_PROG_CC and AC_TRY_COMPILE from adding "-g -O2". if test "${CFLAGS+set}" != "set" ; then CFLAGS="" fi case "`uname -s`" in *win32*|*WIN32*|*MINGW32_*|*MINGW64_*|*MSYS_*) AC_CHECK_PROG(CYGPATH, cygpath, cygpath -m, echo) EXEEXT=".exe" TEA_PLATFORM="windows" ;; *CYGWIN_*) EXEEXT=".exe" # CYGPATH and TEA_PLATFORM are determined later in LOAD_TCLCONFIG ;; *) CYGPATH=echo # Maybe we are cross-compiling.... case ${host_alias} in *mingw32*) EXEEXT=".exe" TEA_PLATFORM="windows" ;; *) EXEEXT="" TEA_PLATFORM="unix" ;; esac ;; esac # Check if exec_prefix is set. If not use fall back to prefix. # Note when adjusted, so that TEA_PREFIX can correct for this. # This is needed for recursive configures, since autoconf propagates # $prefix, but not $exec_prefix (doh!). if test x$exec_prefix = xNONE ; then exec_prefix_default=yes exec_prefix=$prefix fi AC_MSG_NOTICE([configuring ${PACKAGE_NAME} ${PACKAGE_VERSION}]) AC_SUBST(EXEEXT) AC_SUBST(CYGPATH) # This package name must be replaced statically for AC_SUBST to work AC_SUBST(PKG_LIB_FILE) AC_SUBST(PKG_LIB_FILE8) AC_SUBST(PKG_LIB_FILE9) # We AC_SUBST these here to ensure they are subst'ed, # in case the user doesn't call TEA_ADD_... AC_SUBST(PKG_STUB_SOURCES) AC_SUBST(PKG_STUB_OBJECTS) AC_SUBST(PKG_TCL_SOURCES) AC_SUBST(PKG_HEADERS) AC_SUBST(PKG_INCLUDES) AC_SUBST(PKG_LIBS) AC_SUBST(PKG_CFLAGS) # Configure the installer. TEA_INSTALLER ]) #------------------------------------------------------------------------ # TEA_ADD_SOURCES -- # # Specify one or more source files. Users should check for # the right platform before adding to their list. # It is not important to specify the directory, as long as it is # in the generic, win or unix subdirectory of $(srcdir). # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_SOURCES # PKG_OBJECTS #------------------------------------------------------------------------ AC_DEFUN([TEA_ADD_SOURCES], [ vars="$@" for i in $vars; do case $i in [\$]*) # allow $-var names PKG_SOURCES="$PKG_SOURCES $i" PKG_OBJECTS="$PKG_OBJECTS $i" ;; *) # check for existence - allows for generic/win/unix VPATH # To add more dirs here (like 'src'), you have to update VPATH # in Makefile.in as well if test ! -f "${srcdir}/$i" -a ! -f "${srcdir}/generic/$i" \ -a ! -f "${srcdir}/win/$i" -a ! -f "${srcdir}/unix/$i" \ -a ! -f "${srcdir}/macosx/$i" \ ; then AC_MSG_ERROR([could not find source file '$i']) fi PKG_SOURCES="$PKG_SOURCES $i" # this assumes it is in a VPATH dir i=`basename $i` # handle user calling this before or after TEA_SETUP_COMPILER if test x"${OBJEXT}" != x ; then j="`echo $i | sed -e 's/\.[[^.]]*$//'`.${OBJEXT}" else j="`echo $i | sed -e 's/\.[[^.]]*$//'`.\${OBJEXT}" fi PKG_OBJECTS="$PKG_OBJECTS $j" ;; esac done AC_SUBST(PKG_SOURCES) AC_SUBST(PKG_OBJECTS) ]) #------------------------------------------------------------------------ # TEA_ADD_STUB_SOURCES -- # # Specify one or more source files. Users should check for # the right platform before adding to their list. # It is not important to specify the directory, as long as it is # in the generic, win or unix subdirectory of $(srcdir). # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_STUB_SOURCES # PKG_STUB_OBJECTS #------------------------------------------------------------------------ AC_DEFUN([TEA_ADD_STUB_SOURCES], [ vars="$@" for i in $vars; do # check for existence - allows for generic/win/unix VPATH if test ! -f "${srcdir}/$i" -a ! -f "${srcdir}/generic/$i" \ -a ! -f "${srcdir}/win/$i" -a ! -f "${srcdir}/unix/$i" \ -a ! -f "${srcdir}/macosx/$i" \ ; then AC_MSG_ERROR([could not find stub source file '$i']) fi PKG_STUB_SOURCES="$PKG_STUB_SOURCES $i" # this assumes it is in a VPATH dir i=`basename $i` # handle user calling this before or after TEA_SETUP_COMPILER if test x"${OBJEXT}" != x ; then j="`echo $i | sed -e 's/\.[[^.]]*$//'`.${OBJEXT}" else j="`echo $i | sed -e 's/\.[[^.]]*$//'`.\${OBJEXT}" fi PKG_STUB_OBJECTS="$PKG_STUB_OBJECTS $j" done AC_SUBST(PKG_STUB_SOURCES) AC_SUBST(PKG_STUB_OBJECTS) ]) #------------------------------------------------------------------------ # TEA_ADD_TCL_SOURCES -- # # Specify one or more Tcl source files. These should be platform # independent runtime files. # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_TCL_SOURCES #------------------------------------------------------------------------ AC_DEFUN([TEA_ADD_TCL_SOURCES], [ vars="$@" for i in $vars; do # check for existence, be strict because it is installed if test ! -f "${srcdir}/$i" ; then AC_MSG_ERROR([could not find tcl source file '${srcdir}/$i']) fi PKG_TCL_SOURCES="$PKG_TCL_SOURCES $i" done AC_SUBST(PKG_TCL_SOURCES) ]) #------------------------------------------------------------------------ # TEA_ADD_HEADERS -- # # Specify one or more source headers. Users should check for # the right platform before adding to their list. # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_HEADERS #------------------------------------------------------------------------ AC_DEFUN([TEA_ADD_HEADERS], [ vars="$@" for i in $vars; do # check for existence, be strict because it is installed if test ! -f "${srcdir}/$i" ; then AC_MSG_ERROR([could not find header file '${srcdir}/$i']) fi PKG_HEADERS="$PKG_HEADERS $i" done AC_SUBST(PKG_HEADERS) ]) #------------------------------------------------------------------------ # TEA_ADD_INCLUDES -- # # Specify one or more include dirs. Users should check for # the right platform before adding to their list. # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_INCLUDES #------------------------------------------------------------------------ AC_DEFUN([TEA_ADD_INCLUDES], [ vars="$@" for i in $vars; do PKG_INCLUDES="$PKG_INCLUDES $i" done AC_SUBST(PKG_INCLUDES) ]) #------------------------------------------------------------------------ # TEA_ADD_LIBS -- # # Specify one or more libraries. Users should check for # the right platform before adding to their list. For Windows, # libraries provided in "foo.lib" format will be converted to # "-lfoo" when using GCC (mingw). # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_LIBS #------------------------------------------------------------------------ AC_DEFUN([TEA_ADD_LIBS], [ vars="$@" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then # Convert foo.lib to -lfoo for GCC. No-op if not *.lib i=`echo "$i" | sed -e 's/^\([[^-]].*\)\.[[lL]][[iI]][[bB]][$]/-l\1/'` fi PKG_LIBS="$PKG_LIBS $i" done AC_SUBST(PKG_LIBS) ]) #------------------------------------------------------------------------ # TEA_ADD_CFLAGS -- # # Specify one or more CFLAGS. Users should check for # the right platform before adding to their list. # # Arguments: # one or more file names # # Results: # # Defines and substs the following vars: # PKG_CFLAGS #------------------------------------------------------------------------ AC_DEFUN([TEA_ADD_CFLAGS], [ PKG_CFLAGS="$PKG_CFLAGS $@" AC_SUBST(PKG_CFLAGS) ]) #------------------------------------------------------------------------ # TEA_ADD_CLEANFILES -- # # Specify one or more CLEANFILES. # # Arguments: # one or more file names to clean target # # Results: # # Appends to CLEANFILES, already defined for subst in LOAD_TCLCONFIG #------------------------------------------------------------------------ AC_DEFUN([TEA_ADD_CLEANFILES], [ CLEANFILES="$CLEANFILES $@" ]) #------------------------------------------------------------------------ # TEA_PREFIX -- # # Handle the --prefix=... option by defaulting to what Tcl gave # # Arguments: # none # # Results: # # If --prefix or --exec-prefix was not specified, $prefix and # $exec_prefix will be set to the values given to Tcl when it was # configured. #------------------------------------------------------------------------ AC_DEFUN([TEA_PREFIX], [ if test "${prefix}" = "NONE"; then prefix_default=yes if test x"${TCL_PREFIX}" != x; then AC_MSG_NOTICE([--prefix defaulting to TCL_PREFIX ${TCL_PREFIX}]) prefix=${TCL_PREFIX} else AC_MSG_NOTICE([--prefix defaulting to /usr/local]) prefix=/usr/local fi fi if test "${exec_prefix}" = "NONE" -a x"${prefix_default}" = x"yes" \ -o x"${exec_prefix_default}" = x"yes" ; then if test x"${TCL_EXEC_PREFIX}" != x; then AC_MSG_NOTICE([--exec-prefix defaulting to TCL_EXEC_PREFIX ${TCL_EXEC_PREFIX}]) exec_prefix=${TCL_EXEC_PREFIX} else AC_MSG_NOTICE([--exec-prefix defaulting to ${prefix}]) exec_prefix=$prefix fi fi ]) #------------------------------------------------------------------------ # TEA_SETUP_COMPILER_CC -- # # Do compiler checks the way we want. This is just a replacement # for AC_PROG_CC in TEA configure.ac files to make them cleaner. # # Arguments: # none # # Results: # # Sets up CC var and other standard bits we need to make executables. #------------------------------------------------------------------------ AC_DEFUN([TEA_SETUP_COMPILER_CC], [ # Don't put any macros that use the compiler (e.g. AC_TRY_COMPILE) # in this macro, they need to go into TEA_SETUP_COMPILER instead. AC_PROG_CC AC_PROG_CPP #-------------------------------------------------------------------- # Checks to see if the make program sets the $MAKE variable. #-------------------------------------------------------------------- AC_PROG_MAKE_SET #-------------------------------------------------------------------- # Find ranlib #-------------------------------------------------------------------- AC_CHECK_TOOL(RANLIB, ranlib) #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- AC_OBJEXT AC_EXEEXT ]) #------------------------------------------------------------------------ # TEA_SETUP_COMPILER -- # # Do compiler checks that use the compiler. This must go after # TEA_SETUP_COMPILER_CC, which does the actual compiler check. # # Arguments: # none # # Results: # # Sets up CC var and other standard bits we need to make executables. #------------------------------------------------------------------------ AC_DEFUN([TEA_SETUP_COMPILER], [ # Any macros that use the compiler (e.g. AC_TRY_COMPILE) have to go here. AC_REQUIRE([TEA_SETUP_COMPILER_CC]) #------------------------------------------------------------------------ # If we're using GCC, see if the compiler understands -pipe. If so, use it. # It makes compiling go faster. (This is only a performance feature.) #------------------------------------------------------------------------ if test -z "$no_pipe" -a -n "$GCC"; then AC_CACHE_CHECK([if the compiler understands -pipe], tcl_cv_cc_pipe, [ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -pipe" AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[tcl_cv_cc_pipe=yes],[tcl_cv_cc_pipe=no]) CFLAGS=$hold_cflags]) if test $tcl_cv_cc_pipe = yes; then CFLAGS="$CFLAGS -pipe" fi fi if test "${TCL_MAJOR_VERSION}" -lt 9 -a "${TCL_MINOR_VERSION}" -lt 7; then AC_DEFINE(Tcl_Size, int, [Is 'Tcl_Size' in ?]) fi #-------------------------------------------------------------------- # Common compiler flag setup #-------------------------------------------------------------------- AC_C_BIGENDIAN(,,,[#]) ]) #------------------------------------------------------------------------ # TEA_MAKE_LIB -- # # Generate a line that can be used to build a shared/unshared library # in a platform independent manner. # # Arguments: # none # # Requires: # # Results: # # Defines the following vars: # CFLAGS - Done late here to note disturb other AC macros # MAKE_LIB - Command to execute to build the Tcl library; # differs depending on whether or not Tcl is being # compiled as a shared library. # MAKE_SHARED_LIB Makefile rule for building a shared library # MAKE_STATIC_LIB Makefile rule for building a static library # MAKE_STUB_LIB Makefile rule for building a stub library # VC_MANIFEST_EMBED_DLL Makefile rule for embedded VC manifest in DLL # VC_MANIFEST_EMBED_EXE Makefile rule for embedded VC manifest in EXE #------------------------------------------------------------------------ AC_DEFUN([TEA_MAKE_LIB], [ if test "${TEA_PLATFORM}" = "windows" -a "$GCC" != "yes"; then MAKE_STATIC_LIB="\${STLIB_LD} -out:\[$]@ \$(PKG_OBJECTS)" MAKE_SHARED_LIB="\${SHLIB_LD} \${LDFLAGS} \${LDFLAGS_DEFAULT} -out:\[$]@ \$(PKG_OBJECTS) \${SHLIB_LD_LIBS}" AC_EGREP_CPP([manifest needed], [ #if defined(_MSC_VER) && _MSC_VER >= 1400 print("manifest needed") #endif ], [ # Could do a CHECK_PROG for mt, but should always be with MSVC8+ VC_MANIFEST_EMBED_DLL="if test -f \[$]@.manifest ; then mt.exe -nologo -manifest \[$]@.manifest -outputresource:\[$]@\;2 ; fi" VC_MANIFEST_EMBED_EXE="if test -f \[$]@.manifest ; then mt.exe -nologo -manifest \[$]@.manifest -outputresource:\[$]@\;1 ; fi" MAKE_SHARED_LIB="${MAKE_SHARED_LIB} ; ${VC_MANIFEST_EMBED_DLL}" TEA_ADD_CLEANFILES([*.manifest]) ]) MAKE_STUB_LIB="\${STLIB_LD} -nodefaultlib -out:\[$]@ \$(PKG_STUB_OBJECTS)" else MAKE_STATIC_LIB="\${STLIB_LD} \[$]@ \$(PKG_OBJECTS)" MAKE_SHARED_LIB="\${SHLIB_LD} \${LDFLAGS} \${LDFLAGS_DEFAULT} -o \[$]@ \$(PKG_OBJECTS) \${SHLIB_LD_LIBS}" MAKE_STUB_LIB="\${STLIB_LD} \[$]@ \$(PKG_STUB_OBJECTS)" fi if test "${SHARED_BUILD}" = "1" ; then MAKE_LIB="${MAKE_SHARED_LIB} " else MAKE_LIB="${MAKE_STATIC_LIB} " fi #-------------------------------------------------------------------- # Shared libraries and static libraries have different names. # Use the double eval to make sure any variables in the suffix is # substituted. (@@@ Might not be necessary anymore) #-------------------------------------------------------------------- PACKAGE_LIB_PREFIX8="${PACKAGE_LIB_PREFIX}" PACKAGE_LIB_PREFIX9="${PACKAGE_LIB_PREFIX}tcl9" if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tcl8}" = x; then PACKAGE_LIB_PREFIX="${PACKAGE_LIB_PREFIX9}" else PACKAGE_LIB_PREFIX="${PACKAGE_LIB_PREFIX8}" AC_DEFINE(TCL_MAJOR_VERSION, 8, [Compile for Tcl8?]) fi if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tk8}" != x; then AC_DEFINE(TK_MAJOR_VERSION, 8, [Compile for Tk8?]) fi if test "${TEA_PLATFORM}" = "windows" ; then if test "${SHARED_BUILD}" = "1" ; then # We force the unresolved linking of symbols that are really in # the private libraries of Tcl and Tk. if test x"${TK_BIN_DIR}" != x ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TK_BIN_DIR}/${TK_STUB_LIB_FILE}`\"" fi SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}`\"" if test "$GCC" = "yes"; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -static-libgcc" fi eval eval "PKG_LIB_FILE8=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE9=${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" else if test "$GCC" = "yes"; then PACKAGE_LIB_PREFIX=lib${PACKAGE_LIB_PREFIX} fi eval eval "PKG_LIB_FILE8=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE9=${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" fi # Some packages build their own stubs libraries if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tcl8}" = x; then eval eval "PKG_STUB_LIB_FILE=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub.a" else eval eval "PKG_STUB_LIB_FILE=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" fi if test "$GCC" = "yes"; then PKG_STUB_LIB_FILE=lib${PKG_STUB_LIB_FILE} fi # These aren't needed on Windows (either MSVC or gcc) RANLIB=: RANLIB_STUB=: else RANLIB_STUB="${RANLIB}" if test "${SHARED_BUILD}" = "1" ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TCL_STUB_LIB_SPEC}" if test x"${TK_BIN_DIR}" != x ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TK_STUB_LIB_SPEC}" fi eval eval "PKG_LIB_FILE8=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE9=lib${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" RANLIB=: else eval eval "PKG_LIB_FILE8=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE9=lib${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" fi # Some packages build their own stubs libraries if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tcl8}" = x; then eval eval "PKG_STUB_LIB_FILE=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub.a" else eval eval "PKG_STUB_LIB_FILE=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" fi fi # These are escaped so that only CFLAGS is picked up at configure time. # The other values will be substituted at make time. CFLAGS="${CFLAGS} \${CFLAGS_DEFAULT} \${CFLAGS_WARNING}" if test "${SHARED_BUILD}" = "1" ; then CFLAGS="${CFLAGS} \${SHLIB_CFLAGS}" fi AC_SUBST(MAKE_LIB) AC_SUBST(MAKE_SHARED_LIB) AC_SUBST(MAKE_STATIC_LIB) AC_SUBST(MAKE_STUB_LIB) # Substitute STUB_LIB_FILE in case package creates a stub library too. AC_SUBST(PKG_STUB_LIB_FILE) AC_SUBST(RANLIB_STUB) AC_SUBST(VC_MANIFEST_EMBED_DLL) AC_SUBST(VC_MANIFEST_EMBED_EXE) ]) #------------------------------------------------------------------------ # TEA_LIB_SPEC -- # # Compute the name of an existing object library located in libdir # from the given base name and produce the appropriate linker flags. # # Arguments: # basename The base name of the library without version # numbers, extensions, or "lib" prefixes. # extra_dir Extra directory in which to search for the # library. This location is used first, then # $prefix/$exec-prefix, then some defaults. # # Requires: # TEA_INIT and TEA_PREFIX must be called first. # # Results: # # Defines the following vars: # ${basename}_LIB_NAME The computed library name. # ${basename}_LIB_SPEC The computed linker flags. #------------------------------------------------------------------------ AC_DEFUN([TEA_LIB_SPEC], [ AC_MSG_CHECKING([for $1 library]) # Look in exec-prefix for the library (defined by TEA_PREFIX). tea_lib_name_dir="${exec_prefix}/lib" # Or in a user-specified location. if test x"$2" != x ; then tea_extra_lib_dir=$2 else tea_extra_lib_dir=NONE fi for i in \ `ls -dr ${tea_extra_lib_dir}/$1[[0-9]]*.lib 2>/dev/null ` \ `ls -dr ${tea_extra_lib_dir}/lib$1[[0-9]]* 2>/dev/null ` \ `ls -dr ${tea_lib_name_dir}/$1[[0-9]]*.lib 2>/dev/null ` \ `ls -dr ${tea_lib_name_dir}/lib$1[[0-9]]* 2>/dev/null ` \ `ls -dr /usr/lib/$1[[0-9]]*.lib 2>/dev/null ` \ `ls -dr /usr/lib/lib$1[[0-9]]* 2>/dev/null ` \ `ls -dr /usr/lib64/$1[[0-9]]*.lib 2>/dev/null ` \ `ls -dr /usr/lib64/lib$1[[0-9]]* 2>/dev/null ` \ `ls -dr /usr/local/lib/$1[[0-9]]*.lib 2>/dev/null ` \ `ls -dr /usr/local/lib/lib$1[[0-9]]* 2>/dev/null ` ; do if test -f "$i" ; then tea_lib_name_dir=`dirname $i` $1_LIB_NAME=`basename $i` $1_LIB_PATH_NAME=$i break fi done if test "${TEA_PLATFORM}" = "windows"; then $1_LIB_SPEC=\"`${CYGPATH} ${$1_LIB_PATH_NAME} 2>/dev/null`\" else # Strip off the leading "lib" and trailing ".a" or ".so" tea_lib_name_lib=`echo ${$1_LIB_NAME}|sed -e 's/^lib//' -e 's/\.[[^.]]*$//' -e 's/\.so.*//'` $1_LIB_SPEC="-L${tea_lib_name_dir} -l${tea_lib_name_lib}" fi if test "x${$1_LIB_NAME}" = x ; then AC_MSG_ERROR([not found]) else AC_MSG_RESULT([${$1_LIB_SPEC}]) fi ]) #------------------------------------------------------------------------ # TEA_PRIVATE_TCL_HEADERS -- # # Locate the private Tcl include files # # Arguments: # # Requires: # TCL_SRC_DIR Assumes that TEA_LOAD_TCLCONFIG has # already been called. # # Results: # # Substitutes the following vars: # TCL_TOP_DIR_NATIVE # TCL_INCLUDES #------------------------------------------------------------------------ AC_DEFUN([TEA_PRIVATE_TCL_HEADERS], [ # Allow for --with-tclinclude to take effect and define ${ac_cv_c_tclh} AC_REQUIRE([TEA_PUBLIC_TCL_HEADERS]) AC_MSG_CHECKING([for Tcl private include files]) TCL_SRC_DIR_NATIVE=`${CYGPATH} ${TCL_SRC_DIR}` TCL_TOP_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}\" # Check to see if tclPort.h isn't already with the public headers # Don't look for tclInt.h because that resides with tcl.h in the core # sources, but the Port headers are in a different directory if test "${TEA_PLATFORM}" = "windows" -a \ -f "${ac_cv_c_tclh}/tclWinPort.h"; then result="private headers found with public headers" elif test "${TEA_PLATFORM}" = "unix" -a \ -f "${ac_cv_c_tclh}/tclUnixPort.h"; then result="private headers found with public headers" else TCL_GENERIC_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/generic\" if test "${TEA_PLATFORM}" = "windows"; then TCL_PLATFORM_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/win\" else TCL_PLATFORM_DIR_NATIVE=\"${TCL_SRC_DIR_NATIVE}/unix\" fi # Overwrite the previous TCL_INCLUDES as this should capture both # public and private headers in the same set. # We want to ensure these are substituted so as not to require # any *_NATIVE vars be defined in the Makefile TCL_INCLUDES="-I${TCL_GENERIC_DIR_NATIVE} -I${TCL_PLATFORM_DIR_NATIVE}" if test "`uname -s`" = "Darwin"; then # If Tcl was built as a framework, attempt to use # the framework's Headers and PrivateHeaders directories case ${TCL_DEFS} in *TCL_FRAMEWORK*) if test -d "${TCL_BIN_DIR}/Headers" -a \ -d "${TCL_BIN_DIR}/PrivateHeaders"; then TCL_INCLUDES="-I\"${TCL_BIN_DIR}/Headers\" -I\"${TCL_BIN_DIR}/PrivateHeaders\" ${TCL_INCLUDES}" else TCL_INCLUDES="${TCL_INCLUDES} ${TCL_INCLUDE_SPEC} `echo "${TCL_INCLUDE_SPEC}" | sed -e 's/Headers/PrivateHeaders/'`" fi ;; esac result="Using ${TCL_INCLUDES}" else if test ! -f "${TCL_SRC_DIR}/generic/tclInt.h" ; then AC_MSG_ERROR([Cannot find private header tclInt.h in ${TCL_SRC_DIR}]) fi result="Using srcdir found in tclConfig.sh: ${TCL_SRC_DIR}" fi fi AC_SUBST(TCL_TOP_DIR_NATIVE) AC_SUBST(TCL_INCLUDES) AC_MSG_RESULT([${result}]) ]) #------------------------------------------------------------------------ # TEA_PUBLIC_TCL_HEADERS -- # # Locate the installed public Tcl header files # # Arguments: # None. # # Requires: # CYGPATH must be set # # Results: # # Adds a --with-tclinclude switch to configure. # Result is cached. # # Substitutes the following vars: # TCL_INCLUDES #------------------------------------------------------------------------ AC_DEFUN([TEA_PUBLIC_TCL_HEADERS], [ AC_MSG_CHECKING([for Tcl public headers]) AC_ARG_WITH(tclinclude, [ --with-tclinclude directory containing the public Tcl header files], with_tclinclude=${withval}) AC_CACHE_VAL(ac_cv_c_tclh, [ # Use the value from --with-tclinclude, if it was given if test x"${with_tclinclude}" != x ; then if test -f "${with_tclinclude}/tcl.h" ; then ac_cv_c_tclh=${with_tclinclude} else AC_MSG_ERROR([${with_tclinclude} directory does not contain tcl.h]) fi else list="" if test "`uname -s`" = "Darwin"; then # If Tcl was built as a framework, attempt to use # the framework's Headers directory case ${TCL_DEFS} in *TCL_FRAMEWORK*) list="`ls -d ${TCL_BIN_DIR}/Headers 2>/dev/null`" ;; esac fi # Look in the source dir only if Tcl is not installed, # and in that situation, look there before installed locations. if test -f "${TCL_BIN_DIR}/Makefile" ; then list="$list `ls -d ${TCL_SRC_DIR}/generic 2>/dev/null`" fi # Check order: pkg --prefix location, Tcl's --prefix location, # relative to directory of tclConfig.sh. eval "temp_includedir=${includedir}" list="$list \ `ls -d ${temp_includedir} 2>/dev/null` \ `ls -d ${TCL_PREFIX}/include 2>/dev/null` \ `ls -d ${TCL_BIN_DIR}/../include 2>/dev/null`" if test "${TEA_PLATFORM}" != "windows" -o "$GCC" = "yes"; then list="$list /usr/local/include /usr/include" if test x"${TCL_INCLUDE_SPEC}" != x ; then d=`echo "${TCL_INCLUDE_SPEC}" | sed -e 's/^-I//'` list="$list `ls -d ${d} 2>/dev/null`" fi fi for i in $list ; do if test -f "$i/tcl.h" ; then ac_cv_c_tclh=$i break fi done fi ]) # Print a message based on how we determined the include path if test x"${ac_cv_c_tclh}" = x ; then AC_MSG_ERROR([tcl.h not found. Please specify its location with --with-tclinclude]) else AC_MSG_RESULT([${ac_cv_c_tclh}]) fi # Convert to a native path and substitute into the output files. INCLUDE_DIR_NATIVE=`${CYGPATH} ${ac_cv_c_tclh}` TCL_INCLUDES=-I\"${INCLUDE_DIR_NATIVE}\" AC_SUBST(TCL_INCLUDES) ]) #------------------------------------------------------------------------ # TEA_PRIVATE_TK_HEADERS -- # # Locate the private Tk include files # # Arguments: # # Requires: # TK_SRC_DIR Assumes that TEA_LOAD_TKCONFIG has # already been called. # # Results: # # Substitutes the following vars: # TK_INCLUDES #------------------------------------------------------------------------ AC_DEFUN([TEA_PRIVATE_TK_HEADERS], [ # Allow for --with-tkinclude to take effect and define ${ac_cv_c_tkh} AC_REQUIRE([TEA_PUBLIC_TK_HEADERS]) AC_MSG_CHECKING([for Tk private include files]) TK_SRC_DIR_NATIVE=`${CYGPATH} ${TK_SRC_DIR}` TK_TOP_DIR_NATIVE=\"${TK_SRC_DIR_NATIVE}\" # Check to see if tkPort.h isn't already with the public headers # Don't look for tkInt.h because that resides with tk.h in the core # sources, but the Port headers are in a different directory if test "${TEA_PLATFORM}" = "windows" -a \ -f "${ac_cv_c_tkh}/tkWinPort.h"; then result="private headers found with public headers" elif test "${TEA_PLATFORM}" = "unix" -a \ -f "${ac_cv_c_tkh}/tkUnixPort.h"; then result="private headers found with public headers" else TK_GENERIC_DIR_NATIVE=\"${TK_SRC_DIR_NATIVE}/generic\" TK_XLIB_DIR_NATIVE=\"${TK_SRC_DIR_NATIVE}/xlib\" if test "${TEA_PLATFORM}" = "windows"; then TK_PLATFORM_DIR_NATIVE=\"${TK_SRC_DIR_NATIVE}/win\" else TK_PLATFORM_DIR_NATIVE=\"${TK_SRC_DIR_NATIVE}/unix\" fi # Overwrite the previous TK_INCLUDES as this should capture both # public and private headers in the same set. # We want to ensure these are substituted so as not to require # any *_NATIVE vars be defined in the Makefile TK_INCLUDES="-I${TK_GENERIC_DIR_NATIVE} -I${TK_PLATFORM_DIR_NATIVE}" # Detect and add ttk subdir if test -d "${TK_SRC_DIR}/generic/ttk"; then TK_INCLUDES="${TK_INCLUDES} -I\"${TK_SRC_DIR_NATIVE}/generic/ttk\"" fi if test "${TEA_WINDOWINGSYSTEM}" != "x11"; then TK_INCLUDES="${TK_INCLUDES} -I\"${TK_XLIB_DIR_NATIVE}\"" fi if test "${TEA_WINDOWINGSYSTEM}" = "aqua"; then TK_INCLUDES="${TK_INCLUDES} -I\"${TK_SRC_DIR_NATIVE}/macosx\"" fi if test "`uname -s`" = "Darwin"; then # If Tk was built as a framework, attempt to use # the framework's Headers and PrivateHeaders directories case ${TK_DEFS} in *TK_FRAMEWORK*) if test -d "${TK_BIN_DIR}/Headers" -a \ -d "${TK_BIN_DIR}/PrivateHeaders"; then TK_INCLUDES="-I\"${TK_BIN_DIR}/Headers\" -I\"${TK_BIN_DIR}/PrivateHeaders\" ${TK_INCLUDES}" else TK_INCLUDES="${TK_INCLUDES} ${TK_INCLUDE_SPEC} `echo "${TK_INCLUDE_SPEC}" | sed -e 's/Headers/PrivateHeaders/'`" fi ;; esac result="Using ${TK_INCLUDES}" else if test ! -f "${TK_SRC_DIR}/generic/tkInt.h" ; then AC_MSG_ERROR([Cannot find private header tkInt.h in ${TK_SRC_DIR}]) fi result="Using srcdir found in tkConfig.sh: ${TK_SRC_DIR}" fi fi AC_SUBST(TK_TOP_DIR_NATIVE) AC_SUBST(TK_XLIB_DIR_NATIVE) AC_SUBST(TK_INCLUDES) AC_MSG_RESULT([${result}]) ]) #------------------------------------------------------------------------ # TEA_PUBLIC_TK_HEADERS -- # # Locate the installed public Tk header files # # Arguments: # None. # # Requires: # CYGPATH must be set # # Results: # # Adds a --with-tkinclude switch to configure. # Result is cached. # # Substitutes the following vars: # TK_INCLUDES #------------------------------------------------------------------------ AC_DEFUN([TEA_PUBLIC_TK_HEADERS], [ AC_MSG_CHECKING([for Tk public headers]) AC_ARG_WITH(tkinclude, [ --with-tkinclude directory containing the public Tk header files], with_tkinclude=${withval}) AC_CACHE_VAL(ac_cv_c_tkh, [ # Use the value from --with-tkinclude, if it was given if test x"${with_tkinclude}" != x ; then if test -f "${with_tkinclude}/tk.h" ; then ac_cv_c_tkh=${with_tkinclude} else AC_MSG_ERROR([${with_tkinclude} directory does not contain tk.h]) fi else list="" if test "`uname -s`" = "Darwin"; then # If Tk was built as a framework, attempt to use # the framework's Headers directory. case ${TK_DEFS} in *TK_FRAMEWORK*) list="`ls -d ${TK_BIN_DIR}/Headers 2>/dev/null`" ;; esac fi # Look in the source dir only if Tk is not installed, # and in that situation, look there before installed locations. if test -f "${TK_BIN_DIR}/Makefile" ; then list="$list `ls -d ${TK_SRC_DIR}/generic 2>/dev/null`" fi # Check order: pkg --prefix location, Tk's --prefix location, # relative to directory of tkConfig.sh, Tcl's --prefix location, # relative to directory of tclConfig.sh. eval "temp_includedir=${includedir}" list="$list \ `ls -d ${temp_includedir} 2>/dev/null` \ `ls -d ${TK_PREFIX}/include 2>/dev/null` \ `ls -d ${TK_BIN_DIR}/../include 2>/dev/null` \ `ls -d ${TCL_PREFIX}/include 2>/dev/null` \ `ls -d ${TCL_BIN_DIR}/../include 2>/dev/null`" if test "${TEA_PLATFORM}" != "windows" -o "$GCC" = "yes"; then list="$list /usr/local/include /usr/include" if test x"${TK_INCLUDE_SPEC}" != x ; then d=`echo "${TK_INCLUDE_SPEC}" | sed -e 's/^-I//'` list="$list `ls -d ${d} 2>/dev/null`" fi fi for i in $list ; do if test -f "$i/tk.h" ; then ac_cv_c_tkh=$i break fi done fi ]) # Print a message based on how we determined the include path if test x"${ac_cv_c_tkh}" = x ; then AC_MSG_ERROR([tk.h not found. Please specify its location with --with-tkinclude]) else AC_MSG_RESULT([${ac_cv_c_tkh}]) fi # Convert to a native path and substitute into the output files. INCLUDE_DIR_NATIVE=`${CYGPATH} ${ac_cv_c_tkh}` TK_INCLUDES=-I\"${INCLUDE_DIR_NATIVE}\" AC_SUBST(TK_INCLUDES) if test "${TEA_WINDOWINGSYSTEM}" != "x11"; then # On Windows and Aqua, we need the X compat headers AC_MSG_CHECKING([for X11 header files]) if test ! -r "${INCLUDE_DIR_NATIVE}/X11/Xlib.h"; then INCLUDE_DIR_NATIVE="`${CYGPATH} ${TK_SRC_DIR}/xlib`" TK_XINCLUDES=-I\"${INCLUDE_DIR_NATIVE}\" AC_SUBST(TK_XINCLUDES) fi AC_MSG_RESULT([${INCLUDE_DIR_NATIVE}]) fi ]) #------------------------------------------------------------------------ # TEA_PATH_CONFIG -- # # Locate the ${1}Config.sh file and perform a sanity check on # the ${1} compile flags. These are used by packages like # [incr Tk] that load *Config.sh files from more than Tcl and Tk. # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --with-$1=... # # Defines the following vars: # $1_BIN_DIR Full path to the directory containing # the $1Config.sh file #------------------------------------------------------------------------ AC_DEFUN([TEA_PATH_CONFIG], [ # # Ok, lets find the $1 configuration # First, look for one uninstalled. # the alternative search directory is invoked by --with-$1 # if test x"${no_$1}" = x ; then # we reset no_$1 in case something fails here no_$1=true AC_ARG_WITH($1, [ --with-$1 directory containing $1 configuration ($1Config.sh)], with_$1config=${withval}) AC_MSG_CHECKING([for $1 configuration]) AC_CACHE_VAL(ac_cv_c_$1config,[ # First check to see if --with-$1 was specified. if test x"${with_$1config}" != x ; then case ${with_$1config} in */$1Config.sh ) if test -f ${with_$1config}; then AC_MSG_WARN([--with-$1 argument should refer to directory containing $1Config.sh, not to $1Config.sh itself]) with_$1config=`echo ${with_$1config} | sed 's!/$1Config\.sh$!!'` fi;; esac if test -f "${with_$1config}/$1Config.sh" ; then ac_cv_c_$1config=`(cd ${with_$1config}; pwd)` else AC_MSG_ERROR([${with_$1config} directory doesn't contain $1Config.sh]) fi fi # then check for a private $1 installation if test x"${ac_cv_c_$1config}" = x ; then for i in \ ../$1 \ `ls -dr ../$1*[[0-9]].[[0-9]]*.[[0-9]]* 2>/dev/null` \ `ls -dr ../$1*[[0-9]].[[0-9]][[0-9]] 2>/dev/null` \ `ls -dr ../$1*[[0-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../$1*[[0-9]].[[0-9]]* 2>/dev/null` \ ../../$1 \ `ls -dr ../../$1*[[0-9]].[[0-9]]*.[[0-9]]* 2>/dev/null` \ `ls -dr ../../$1*[[0-9]].[[0-9]][[0-9]] 2>/dev/null` \ `ls -dr ../../$1*[[0-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../$1*[[0-9]].[[0-9]]* 2>/dev/null` \ ../../../$1 \ `ls -dr ../../../$1*[[0-9]].[[0-9]]*.[[0-9]]* 2>/dev/null` \ `ls -dr ../../../$1*[[0-9]].[[0-9]][[0-9]] 2>/dev/null` \ `ls -dr ../../../$1*[[0-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../../$1*[[0-9]].[[0-9]]* 2>/dev/null` \ ${srcdir}/../$1 \ `ls -dr ${srcdir}/../$1*[[0-9]].[[0-9]]*.[[0-9]]* 2>/dev/null` \ `ls -dr ${srcdir}/../$1*[[0-9]].[[0-9]][[0-9]] 2>/dev/null` \ `ls -dr ${srcdir}/../$1*[[0-9]].[[0-9]] 2>/dev/null` \ `ls -dr ${srcdir}/../$1*[[0-9]].[[0-9]]* 2>/dev/null` \ ; do if test -f "$i/$1Config.sh" ; then ac_cv_c_$1config=`(cd $i; pwd)` break fi if test -f "$i/unix/$1Config.sh" ; then ac_cv_c_$1config=`(cd $i/unix; pwd)` break fi done fi # check in a few common install locations if test x"${ac_cv_c_$1config}" = x ; then for i in `ls -d ${libdir} 2>/dev/null` \ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/pkg/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ ; do if test -f "$i/$1Config.sh" ; then ac_cv_c_$1config=`(cd $i; pwd)` break fi done fi ]) if test x"${ac_cv_c_$1config}" = x ; then $1_BIN_DIR="# no $1 configs found" AC_MSG_WARN([Cannot find $1 configuration definitions]) exit 0 else no_$1= $1_BIN_DIR=${ac_cv_c_$1config} AC_MSG_RESULT([found $$1_BIN_DIR/$1Config.sh]) fi fi ]) #------------------------------------------------------------------------ # TEA_LOAD_CONFIG -- # # Load the $1Config.sh file # # Arguments: # # Requires the following vars to be set: # $1_BIN_DIR # # Results: # # Substitutes the following vars: # $1_SRC_DIR # $1_LIB_FILE # $1_LIB_SPEC #------------------------------------------------------------------------ AC_DEFUN([TEA_LOAD_CONFIG], [ AC_MSG_CHECKING([for existence of ${$1_BIN_DIR}/$1Config.sh]) if test -f "${$1_BIN_DIR}/$1Config.sh" ; then AC_MSG_RESULT([loading]) . "${$1_BIN_DIR}/$1Config.sh" else AC_MSG_RESULT([file not found]) fi # # If the $1_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable $1_LIB_SPEC will be set to the value # of $1_BUILD_LIB_SPEC. An extension should make use of $1_LIB_SPEC # instead of $1_BUILD_LIB_SPEC since it will work with both an # installed and uninstalled version of Tcl. # if test -f "${$1_BIN_DIR}/Makefile" ; then AC_MSG_WARN([Found Makefile - using build library specs for $1]) $1_LIB_SPEC=${$1_BUILD_LIB_SPEC} $1_STUB_LIB_SPEC=${$1_BUILD_STUB_LIB_SPEC} $1_STUB_LIB_PATH=${$1_BUILD_STUB_LIB_PATH} $1_INCLUDE_SPEC=${$1_BUILD_INCLUDE_SPEC} $1_LIBRARY_PATH=${$1_LIBRARY_PATH} fi AC_SUBST($1_VERSION) AC_SUBST($1_BIN_DIR) AC_SUBST($1_SRC_DIR) AC_SUBST($1_LIB_FILE) AC_SUBST($1_LIB_SPEC) AC_SUBST($1_STUB_LIB_FILE) AC_SUBST($1_STUB_LIB_SPEC) AC_SUBST($1_STUB_LIB_PATH) # Allow the caller to prevent this auto-check by specifying any 2nd arg AS_IF([test "x$2" = x], [ # Check both upper and lower-case variants # If a dev wanted non-stubs libs, this function could take an option # to not use _STUB in the paths below AS_IF([test "x${$1_STUB_LIB_SPEC}" = x], [TEA_LOAD_CONFIG_LIB(translit($1,[a-z],[A-Z])_STUB)], [TEA_LOAD_CONFIG_LIB($1_STUB)]) ]) ]) #------------------------------------------------------------------------ # TEA_LOAD_CONFIG_LIB -- # # Helper function to load correct library from another extension's # ${PACKAGE}Config.sh. # # Results: # Adds to LIBS the appropriate extension library #------------------------------------------------------------------------ AC_DEFUN([TEA_LOAD_CONFIG_LIB], [ AC_MSG_CHECKING([For $1 library for LIBS]) # This simplifies the use of stub libraries by automatically adding # the stub lib to your path. Normally this would add to SHLIB_LD_LIBS, # but this is called before CONFIG_CFLAGS. More importantly, this adds # to PKG_LIBS, which becomes LIBS, and that is only used by SHLIB_LD. if test "x${$1_LIB_SPEC}" != "x" ; then if test "${TEA_PLATFORM}" = "windows" -a "$GCC" != "yes" ; then TEA_ADD_LIBS([\"`${CYGPATH} ${$1_LIB_PATH}`\"]) AC_MSG_RESULT([using $1_LIB_PATH ${$1_LIB_PATH}]) else TEA_ADD_LIBS([${$1_LIB_SPEC}]) AC_MSG_RESULT([using $1_LIB_SPEC ${$1_LIB_SPEC}]) fi else AC_MSG_RESULT([file not found]) fi ]) #------------------------------------------------------------------------ # TEA_EXPORT_CONFIG -- # # Define the data to insert into the ${PACKAGE}Config.sh file # # Arguments: # # Requires the following vars to be set: # $1 # # Results: # Substitutes the following vars: #------------------------------------------------------------------------ AC_DEFUN([TEA_EXPORT_CONFIG], [ #-------------------------------------------------------------------- # These are for $1Config.sh #-------------------------------------------------------------------- # pkglibdir must be a fully qualified path and (not ${exec_prefix}/lib) eval pkglibdir="[$]{libdir}/$1${PACKAGE_VERSION}" if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then eval $1_LIB_FLAG="-l$1${PACKAGE_VERSION}" eval $1_STUB_LIB_FLAG="-l$1stub${PACKAGE_VERSION}" else eval $1_LIB_FLAG="-l$1`echo ${PACKAGE_VERSION} | tr -d .`" eval $1_STUB_LIB_FLAG="-l$1stub`echo ${PACKAGE_VERSION} | tr -d .`" fi if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tcl8}" = x; then eval $1_STUB_LIB_FLAG="-l$1stub" fi $1_BUILD_LIB_SPEC="-L`$CYGPATH $(pwd)` ${$1_LIB_FLAG}" $1_LIB_SPEC="-L`$CYGPATH ${pkglibdir}` ${$1_LIB_FLAG}" $1_BUILD_STUB_LIB_SPEC="-L`$CYGPATH $(pwd)` [$]{$1_STUB_LIB_FLAG}" $1_STUB_LIB_SPEC="-L`$CYGPATH ${pkglibdir}` [$]{$1_STUB_LIB_FLAG}" $1_BUILD_STUB_LIB_PATH="`$CYGPATH $(pwd)`/[$]{PKG_STUB_LIB_FILE}" $1_STUB_LIB_PATH="`$CYGPATH ${pkglibdir}`/[$]{PKG_STUB_LIB_FILE}" AC_SUBST($1_BUILD_LIB_SPEC) AC_SUBST($1_LIB_SPEC) AC_SUBST($1_BUILD_STUB_LIB_SPEC) AC_SUBST($1_STUB_LIB_SPEC) AC_SUBST($1_BUILD_STUB_LIB_PATH) AC_SUBST($1_STUB_LIB_PATH) AC_SUBST(MAJOR_VERSION) AC_SUBST(MINOR_VERSION) AC_SUBST(PATCHLEVEL) ]) #------------------------------------------------------------------------ # TEA_INSTALLER -- # # Configure the installer. # # Arguments: # none # # Results: # Substitutes the following vars: # INSTALL # INSTALL_DATA_DIR # INSTALL_DATA # INSTALL_PROGRAM # INSTALL_SCRIPT # INSTALL_LIBRARY #------------------------------------------------------------------------ AC_DEFUN([TEA_INSTALLER], [ INSTALL='$(SHELL) $(srcdir)/tclconfig/install-sh -c' INSTALL_DATA_DIR='${INSTALL} -d -m 755' INSTALL_DATA='${INSTALL} -m 644' INSTALL_PROGRAM='${INSTALL} -m 755' INSTALL_SCRIPT='${INSTALL} -m 755' TEA_CONFIG_SYSTEM case $system in HP-UX-*) INSTALL_LIBRARY='${INSTALL} -m 755' ;; *) INSTALL_LIBRARY='${INSTALL} -m 644' ;; esac AC_SUBST(INSTALL) AC_SUBST(INSTALL_DATA_DIR) AC_SUBST(INSTALL_DATA) AC_SUBST(INSTALL_PROGRAM) AC_SUBST(INSTALL_SCRIPT) AC_SUBST(INSTALL_LIBRARY) ]) ### # Tip 430 - ZipFS Modifications ### #------------------------------------------------------------------------ # TEA_ZIPFS_SUPPORT # Locate a zip encoder installed on the system path, or none. # # Arguments: # none # # Results: # Substitutes the following vars: # MACHER_PROG # ZIP_PROG # ZIP_PROG_OPTIONS # ZIP_PROG_VFSSEARCH # ZIP_INSTALL_OBJS #------------------------------------------------------------------------ AC_DEFUN([TEA_ZIPFS_SUPPORT], [ MACHER_PROG="" ZIP_PROG="" ZIP_PROG_OPTIONS="" ZIP_PROG_VFSSEARCH="" ZIP_INSTALL_OBJS="" AC_MSG_CHECKING([for macher]) AC_CACHE_VAL(ac_cv_path_macher, [ search_path=`echo ${PATH} | sed -e 's/:/ /g'` for dir in $search_path ; do for j in `ls -r $dir/macher 2> /dev/null` \ `ls -r $dir/macher 2> /dev/null` ; do if test x"$ac_cv_path_macher" = x ; then if test -f "$j" ; then ac_cv_path_macher=$j break fi fi done done ]) if test -f "$ac_cv_path_macher" ; then MACHER_PROG="$ac_cv_path_macher" AC_MSG_RESULT([$MACHER_PROG]) AC_MSG_RESULT([Found macher in environment]) fi AC_MSG_CHECKING([for zip]) AC_CACHE_VAL(ac_cv_path_zip, [ search_path=`echo ${PATH} | sed -e 's/:/ /g'` for dir in $search_path ; do for j in `ls -r $dir/zip 2> /dev/null` \ `ls -r $dir/zip 2> /dev/null` ; do if test x"$ac_cv_path_zip" = x ; then if test -f "$j" ; then ac_cv_path_zip=$j break fi fi done done ]) if test -f "$ac_cv_path_zip" ; then ZIP_PROG="$ac_cv_path_zip" AC_MSG_RESULT([$ZIP_PROG]) ZIP_PROG_OPTIONS="-rq" ZIP_PROG_VFSSEARCH="*" AC_MSG_RESULT([Found INFO Zip in environment]) # Use standard arguments for zip else # It is not an error if an installed version of Zip can't be located. # We can use the locally distributed minizip instead ZIP_PROG="./minizip${EXEEXT_FOR_BUILD}" ZIP_PROG_OPTIONS="-o -r" ZIP_PROG_VFSSEARCH="*" ZIP_INSTALL_OBJS="minizip${EXEEXT_FOR_BUILD}" AC_MSG_RESULT([No zip found on PATH. Building minizip]) fi AC_SUBST(MACHER_PROG) AC_SUBST(ZIP_PROG) AC_SUBST(ZIP_PROG_OPTIONS) AC_SUBST(ZIP_PROG_VFSSEARCH) AC_SUBST(ZIP_INSTALL_OBJS) ]) # Local Variables: # mode: autoconf # End: thread3.0.1/tclconfig/README.txt0000644003604700454610000000150414726633515014762 0ustar dgp771divThese files comprise the basic building blocks for a Tcl Extension Architecture (TEA) extension. For more information on TEA see: http://www.tcl.tk/doc/tea/ This package is part of the Tcl project at SourceForge, but sources and bug/patch database are hosted on fossil here: https://core.tcl-lang.org/tclconfig This package is a freely available open source package. You can do virtually anything you like with it, such as modifying it, redistributing it, and selling it either in whole or in part. CONTENTS ======== The following is a short description of the files you will find in the sample extension. README.txt This file install-sh Program used for copying binaries and script files to their install locations. tcl.m4 Collection of Tcl autoconf macros. Included by a package's aclocal.m4 to define TEA_* macros. thread3.0.1/configure0000755003604700454610000107727014726633451013240 0ustar dgp771div#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.72 for thread 3.0.1. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2023 Free Software Foundation, # Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case e in #( e) case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac ;; esac fi # Reset variables that may have inherited troublesome values from # the environment. # IFS needs to be set, to space, tab, and newline, in precisely that order. # (If _AS_PATH_WALK were called with IFS unset, it would have the # side effect of setting IFS to empty, thus disabling word splitting.) # Quoting is to prevent editors from complaining about space-tab. as_nl=' ' export as_nl IFS=" "" $as_nl" PS1='$ ' PS2='> ' PS4='+ ' # Ensure predictable behavior from utilities with locale-dependent output. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # We cannot yet rely on "unset" to work, but we need these variables # to be unset--not just set to an empty or harmless value--now, to # avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct # also avoids known problems related to "unset" and subshell syntax # in other old shells (e.g. bash 2.01 and pdksh 5.2.14). for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH do eval test \${$as_var+y} \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done # Ensure that fds 0, 1, and 2 are open. if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi if (exec 3>&2) ; then :; else exec 2>/dev/null; fi # The user is always right. if ${PATH_SEPARATOR+false} :; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac test -r "$as_dir$0" && as_myself=$as_dir$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as 'sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed 'exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case e in #( e) case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ) then : else case e in #( e) exitcode=1; echo positional parameters were not saved. ;; esac fi test x\$exitcode = x0 || exit 1 blah=\$(echo \$(echo blah)) test x\"\$blah\" = xblah || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 test \$(( 1 + 1 )) = 2 || exit 1" if (eval "$as_required") 2>/dev/null then : as_have_required=yes else case e in #( e) as_have_required=no ;; esac fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null then : else case e in #( e) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$as_shell as_have_required=yes if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null then : break 2 fi fi done;; esac as_found=false done IFS=$as_save_IFS if $as_found then : else case e in #( e) if { test -f "$SHELL" || test -f "$SHELL.exe"; } && as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$SHELL as_have_required=yes fi ;; esac fi if test "x$CONFIG_SHELL" != x then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed 'exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno then : printf "%s\n" "$0: This script requires a shell more modern than all" printf "%s\n" "$0: the shells that I found on your system." if test ${ZSH_VERSION+y} ; then printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should" printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later." else printf "%s\n" "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi ;; esac fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null then : eval 'as_fn_append () { eval $1+=\$2 }' else case e in #( e) as_fn_append () { eval $1=\$$1\$2 } ;; esac fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null then : eval 'as_fn_arith () { as_val=$(( $* )) }' else case e in #( e) as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } ;; esac fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi printf "%s\n" "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' t clear :clear s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } # Determine whether it's possible to make 'echo' print without a newline. # These variables are no longer used directly by Autoconf, but are AC_SUBSTed # for compatibility with existing Makefiles. ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac # For backward compatibility with old third-party macros, we provide # the shell variables $as_echo and $as_echo_n. New code should use # AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. as_echo='printf %s\n' as_echo_n='printf %s' rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both 'ln -s file dir' and 'ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; 'ln -s' creates a wrapper executable. # In both cases, we have to default to 'cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_sed_cpp="y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" as_tr_cpp="eval sed '$as_sed_cpp'" # deprecated # Sed expression to map a string onto a valid variable name. as_sed_sh="y%*+%pp%;s%[^_$as_cr_alnum]%_%g" as_tr_sh="eval sed '$as_sed_sh'" # deprecated test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='thread' PACKAGE_TARNAME='thread' PACKAGE_VERSION='3.0.1' PACKAGE_STRING='thread 3.0.1' PACKAGE_BUGREPORT='' PACKAGE_URL='' # Factoring default headers for most tests. ac_includes_default="\ #include #ifdef HAVE_STDIO_H # include #endif #ifdef HAVE_STDLIB_H # include #endif #ifdef HAVE_STRING_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif" ac_header_c_list= ac_subst_vars='LTLIBOBJS INSTALL_MSGS INSTALL_LIBRARIES THREAD_ZIP_FILE ZIPFS_BUILD TCLSH_PROG VC_MANIFEST_EMBED_EXE VC_MANIFEST_EMBED_DLL RANLIB_STUB PKG_STUB_LIB_FILE MAKE_STUB_LIB MAKE_STATIC_LIB MAKE_SHARED_LIB MAKE_LIB LDFLAGS_DEFAULT CFLAGS_DEFAULT LD_LIBRARY_PATH_VAR SHLIB_CFLAGS SHLIB_LD_LIBS SHLIB_LD STLIB_LD LDFLAGS_OPTIMIZE LDFLAGS_DEBUG CFLAGS_WARNING CFLAGS_OPTIMIZE CFLAGS_DEBUG LIBOBJS RC AR STUBS_BUILD SHARED_BUILD TCL_THREADS TCL_INCLUDES PKG_OBJECTS PKG_SOURCES RANLIB SET_MAKE CPP TCL_SHLIB_LD_LIBS TCL_LD_FLAGS TCL_EXTRA_CFLAGS TCL_DEFS TCL_LIBS CLEANFILES OBJEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC TCL_STUB_LIB_SPEC TCL_STUB_LIB_FLAG TCL_STUB_LIB_FILE TCL_LIB_SPEC TCL_LIB_FLAG TCL_LIB_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_PATCH_LEVEL TCL_VERSION INSTALL_LIBRARY INSTALL_SCRIPT INSTALL_PROGRAM INSTALL_DATA INSTALL_DATA_DIR INSTALL PKG_CFLAGS PKG_LIBS PKG_INCLUDES PKG_HEADERS PKG_TCL_SOURCES PKG_STUB_OBJECTS PKG_STUB_SOURCES PKG_LIB_FILE9 PKG_LIB_FILE8 PKG_LIB_FILE EXEEXT CYGPATH target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir runstatedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking with_tcl with_tcl8 with_gdbm with_lmdb with_naviserver with_tclinclude enable_threads enable_shared enable_stubs enable_64bit enable_64bit_vis enable_rpath enable_symbols enable_zipfs ' ac_precious_vars='build_alias host_alias target_alias CC CFLAGS LDFLAGS LIBS CPPFLAGS CPP' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -runstatedir | --runstatedir | --runstatedi | --runstated \ | --runstate | --runstat | --runsta | --runst | --runs \ | --run | --ru | --r) ac_prev=runstatedir ;; -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ | --run=* | --ru=* | --r=*) runstatedir=$ac_optarg ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: '$ac_option' Try '$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: '$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. printf "%s\n" "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: '$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but 'cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF 'configure' configures thread 3.0.1 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print 'checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for '--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or '..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, 'make install' will install all the files in '$ac_default_prefix/bin', '$ac_default_prefix/lib' etc. You can specify an installation prefix other than '$ac_default_prefix' using '--prefix', for instance '--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/thread] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of thread 3.0.1:";; esac cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-threads build with threads (default: on) --enable-shared build and link with shared libraries (default: on) --enable-stubs build and link with stub libraries. Always true for shared builds (default: on) --enable-64bit enable 64bit support (default: off) --enable-64bit-vis enable 64bit Sparc VIS support (default: off) --disable-rpath disable rpath support (default: on) --enable-symbols build with debugging symbols (default: off) --enable-zipfs build with Zipfs support (default: on) Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-tcl directory containing tcl configuration (tclConfig.sh) --with-tcl8 Compile for Tcl8 in Tcl9 environment --with-gdbm link with optional GDBM support --with-lmdb link with optional LMDB support --with-naviserver directory with NaviServer/AOLserver distribution --with-tclinclude directory containing the public Tcl header files Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor Use these variables to override the choices made by 'configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to the package provider. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for configure.gnu first; this name is used for a wrapper for # Metaconfig's "Configure" on case-insensitive file systems. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF thread configure 3.0.1 generated by GNU Autoconf 2.72 Copyright (C) 2023 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## # ac_fn_c_try_compile LINENO # -------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest.beam if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext then : ac_retval=0 else case e in #( e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 ;; esac fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_compile # ac_fn_c_try_cpp LINENO # ---------------------- # Try to preprocess conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_cpp () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } > conftest.i && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err } then : ac_retval=0 else case e in #( e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 ;; esac fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_cpp # ac_fn_c_try_link LINENO # ----------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_link () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || test -x conftest$ac_exeext } then : ac_retval=0 else case e in #( e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 ;; esac fi # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would # interfere with the next link command; also delete a directory that is # left behind by Apple's compiler. We do this before executing the actions. rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_link # ac_fn_c_try_run LINENO # ---------------------- # Try to run conftest.$ac_ext, and return whether this succeeded. Assumes that # executables *can* be run. ac_fn_c_try_run () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; } then : ac_retval=0 else case e in #( e) printf "%s\n" "$as_me: program exited with status $ac_status" >&5 printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=$ac_status ;; esac fi rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_run # ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists and can be compiled using the include files in # INCLUDES, setting the cache variable VAR accordingly. ac_fn_c_check_header_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 printf %s "checking for $2... " >&6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO" then : eval "$3=yes" else case e in #( e) eval "$3=no" ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 printf "%s\n" "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_compile # ac_fn_c_check_func LINENO FUNC VAR # ---------------------------------- # Tests whether FUNC exists, setting the cache variable VAR accordingly ac_fn_c_check_func () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 printf %s "checking for $2... " >&6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Define $2 to an innocuous variant, in case declares $2. For example, HP-UX 11i declares gettimeofday. */ #define $2 innocuous_$2 /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $2 (void); below. */ #include #undef $2 /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $2 (void); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$2 || defined __stub___$2 choke me #endif int main (void) { return $2 (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : eval "$3=yes" else case e in #( e) eval "$3=no" ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext ;; esac fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 printf "%s\n" "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_func ac_configure_args_raw= for ac_arg do case $ac_arg in *\'*) ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append ac_configure_args_raw " '$ac_arg'" done case $ac_configure_args_raw in *$as_nl*) ac_safe_unquote= ;; *) ac_unsafe_z='|&;<>()$`\\"*?[ '' ' # This string ends in space, tab. ac_unsafe_a="$ac_unsafe_z#~" ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g" ac_configure_args_raw=` printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;; esac cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by thread $as_me 3.0.1, which was generated by GNU Autoconf 2.72. Invocation command line was $ $0$ac_configure_args_raw _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac printf "%s\n" "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Sanitize IFS. IFS=" "" $as_nl" # Save into config.log some information that might help in debugging. { echo printf "%s\n" "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo printf "%s\n" "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac printf "%s\n" "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then printf "%s\n" "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac printf "%s\n" "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then printf "%s\n" "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && printf "%s\n" "$as_me: caught signal $ac_signal" printf "%s\n" "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h printf "%s\n" "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. if test -n "$CONFIG_SITE"; then ac_site_files="$CONFIG_SITE" elif test "x$prefix" != xNONE; then ac_site_files="$prefix/share/config.site $prefix/etc/config.site" else ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" fi for ac_site_file in $ac_site_files do case $ac_site_file in #( */*) : ;; #( *) : ac_site_file=./$ac_site_file ;; esac if test -f "$ac_site_file" && test -r "$ac_site_file"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See 'config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 printf "%s\n" "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 printf "%s\n" "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Test code for whether the C compiler supports C89 (global declarations) ac_c_conftest_c89_globals=' /* Does the compiler advertise C89 conformance? Do not test the value of __STDC__, because some compilers set it to 0 while being otherwise adequately conformant. */ #if !defined __STDC__ # error "Compiler does not advertise C89 conformance" #endif #include #include struct stat; /* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */ struct buf { int x; }; struct buf * (*rcsopen) (struct buf *, struct stat *, int); static char *e (char **p, int i) { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* C89 style stringification. */ #define noexpand_stringify(a) #a const char *stringified = noexpand_stringify(arbitrary+token=sequence); /* C89 style token pasting. Exercises some of the corner cases that e.g. old MSVC gets wrong, but not very hard. */ #define noexpand_concat(a,b) a##b #define expand_concat(a,b) noexpand_concat(a,b) extern int vA; extern int vbee; #define aye A #define bee B int *pvA = &expand_concat(v,aye); int *pvbee = &noexpand_concat(v,bee); /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not \xHH hex character constants. These do not provoke an error unfortunately, instead are silently treated as an "x". The following induces an error, until -std is added to get proper ANSI mode. Curiously \x00 != x always comes out true, for an array size at least. It is necessary to write \x00 == 0 to get something that is true only with -std. */ int osf4_cc_array ['\''\x00'\'' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) '\''x'\'' int xlc6_cc_array[FOO(a) == '\''x'\'' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, int *(*)(struct buf *, struct stat *, int), int, int);' # Test code for whether the C compiler supports C89 (body of main). ac_c_conftest_c89_main=' ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]); ' # Test code for whether the C compiler supports C99 (global declarations) ac_c_conftest_c99_globals=' /* Does the compiler advertise C99 conformance? */ #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L # error "Compiler does not advertise C99 conformance" #endif // See if C++-style comments work. #include extern int puts (const char *); extern int printf (const char *, ...); extern int dprintf (int, const char *, ...); extern void *malloc (size_t); extern void free (void *); // Check varargs macros. These examples are taken from C99 6.10.3.5. // dprintf is used instead of fprintf to avoid needing to declare // FILE and stderr. #define debug(...) dprintf (2, __VA_ARGS__) #define showlist(...) puts (#__VA_ARGS__) #define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__)) static void test_varargs_macros (void) { int x = 1234; int y = 5678; debug ("Flag"); debug ("X = %d\n", x); showlist (The first, second, and third items.); report (x>y, "x is %d but y is %d", x, y); } // Check long long types. #define BIG64 18446744073709551615ull #define BIG32 4294967295ul #define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0) #if !BIG_OK #error "your preprocessor is broken" #endif #if BIG_OK #else #error "your preprocessor is broken" #endif static long long int bignum = -9223372036854775807LL; static unsigned long long int ubignum = BIG64; struct incomplete_array { int datasize; double data[]; }; struct named_init { int number; const wchar_t *name; double average; }; typedef const char *ccp; static inline int test_restrict (ccp restrict text) { // Iterate through items via the restricted pointer. // Also check for declarations in for loops. for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i) continue; return 0; } // Check varargs and va_copy. static bool test_varargs (const char *format, ...) { va_list args; va_start (args, format); va_list args_copy; va_copy (args_copy, args); const char *str = ""; int number = 0; float fnumber = 0; while (*format) { switch (*format++) { case '\''s'\'': // string str = va_arg (args_copy, const char *); break; case '\''d'\'': // int number = va_arg (args_copy, int); break; case '\''f'\'': // float fnumber = va_arg (args_copy, double); break; default: break; } } va_end (args_copy); va_end (args); return *str && number && fnumber; } ' # Test code for whether the C compiler supports C99 (body of main). ac_c_conftest_c99_main=' // Check bool. _Bool success = false; success |= (argc != 0); // Check restrict. if (test_restrict ("String literal") == 0) success = true; char *restrict newvar = "Another string"; // Check varargs. success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234); test_varargs_macros (); // Check flexible array members. struct incomplete_array *ia = malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10)); ia->datasize = 10; for (int i = 0; i < ia->datasize; ++i) ia->data[i] = i * 1.234; // Work around memory leak warnings. free (ia); // Check named initializers. struct named_init ni = { .number = 34, .name = L"Test wide string", .average = 543.34343, }; ni.number = 58; int dynamic_array[ni.number]; dynamic_array[0] = argv[0][0]; dynamic_array[ni.number - 1] = 543; // work around unused variable warnings ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\'' || dynamic_array[ni.number - 1] != 543); ' # Test code for whether the C compiler supports C11 (global declarations) ac_c_conftest_c11_globals=' /* Does the compiler advertise C11 conformance? */ #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L # error "Compiler does not advertise C11 conformance" #endif // Check _Alignas. char _Alignas (double) aligned_as_double; char _Alignas (0) no_special_alignment; extern char aligned_as_int; char _Alignas (0) _Alignas (int) aligned_as_int; // Check _Alignof. enum { int_alignment = _Alignof (int), int_array_alignment = _Alignof (int[100]), char_alignment = _Alignof (char) }; _Static_assert (0 < -_Alignof (int), "_Alignof is signed"); // Check _Noreturn. int _Noreturn does_not_return (void) { for (;;) continue; } // Check _Static_assert. struct test_static_assert { int x; _Static_assert (sizeof (int) <= sizeof (long int), "_Static_assert does not work in struct"); long int y; }; // Check UTF-8 literals. #define u8 syntax error! char const utf8_literal[] = u8"happens to be ASCII" "another string"; // Check duplicate typedefs. typedef long *long_ptr; typedef long int *long_ptr; typedef long_ptr long_ptr; // Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1. struct anonymous { union { struct { int i; int j; }; struct { int k; long int l; } w; }; int m; } v1; ' # Test code for whether the C compiler supports C11 (body of main). ac_c_conftest_c11_main=' _Static_assert ((offsetof (struct anonymous, i) == offsetof (struct anonymous, w.k)), "Anonymous union alignment botch"); v1.i = 2; v1.w.k = 5; ok |= v1.i != 5; ' # Test code for whether the C compiler supports C11 (complete). ac_c_conftest_c11_program="${ac_c_conftest_c89_globals} ${ac_c_conftest_c99_globals} ${ac_c_conftest_c11_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} ${ac_c_conftest_c99_main} ${ac_c_conftest_c11_main} return ok; } " # Test code for whether the C compiler supports C99 (complete). ac_c_conftest_c99_program="${ac_c_conftest_c89_globals} ${ac_c_conftest_c99_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} ${ac_c_conftest_c99_main} return ok; } " # Test code for whether the C compiler supports C89 (complete). ac_c_conftest_c89_program="${ac_c_conftest_c89_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} return ok; } " as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H" as_fn_append ac_header_c_list " stdlib.h stdlib_h HAVE_STDLIB_H" as_fn_append ac_header_c_list " string.h string_h HAVE_STRING_H" as_fn_append ac_header_c_list " inttypes.h inttypes_h HAVE_INTTYPES_H" as_fn_append ac_header_c_list " stdint.h stdint_h HAVE_STDINT_H" as_fn_append ac_header_c_list " strings.h strings_h HAVE_STRINGS_H" as_fn_append ac_header_c_list " sys/stat.h sys_stat_h HAVE_SYS_STAT_H" as_fn_append ac_header_c_list " sys/types.h sys_types_h HAVE_SYS_TYPES_H" as_fn_append ac_header_c_list " unistd.h unistd_h HAVE_UNISTD_H" # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' was set to '$ac_old_val' in the previous run" >&5 printf "%s\n" "$as_me: error: '$ac_var' was set to '$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' was not set in the previous run" >&5 printf "%s\n" "$as_me: error: '$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' has changed since the previous run:" >&5 printf "%s\n" "$as_me: error: '$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in '$ac_var' since the previous run:" >&5 printf "%s\n" "$as_me: warning: ignoring whitespace changes in '$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: '$ac_old_val'" >&5 printf "%s\n" "$as_me: former value: '$ac_old_val'" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: '$ac_new_val'" >&5 printf "%s\n" "$as_me: current value: '$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`printf "%s\n" "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run '${MAKE-make} distclean' and/or 'rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu #-------------------------------------------------------------------- # Call TEA_INIT as the first TEA_ macro to set up initial vars. # This will define a ${TEA_PLATFORM} variable == "unix" or "windows" # as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE. #-------------------------------------------------------------------- TEA_VERSION="3.13" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking TEA configuration" >&5 printf %s "checking TEA configuration... " >&6; } if test x"${PACKAGE_NAME}" = x ; then as_fn_error $? " The PACKAGE_NAME variable must be defined by your TEA configure.ac" "$LINENO" 5 fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ok (TEA ${TEA_VERSION})" >&5 printf "%s\n" "ok (TEA ${TEA_VERSION})" >&6; } # If the user did not set CFLAGS, set it now to keep macros # like AC_PROG_CC and AC_TRY_COMPILE from adding "-g -O2". if test "${CFLAGS+set}" != "set" ; then CFLAGS="" fi case "`uname -s`" in *win32*|*WIN32*|*MINGW32_*|*MINGW64_*|*MSYS_*) # Extract the first word of "cygpath", so it can be a program name with args. set dummy cygpath; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CYGPATH+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CYGPATH"; then ac_cv_prog_CYGPATH="$CYGPATH" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CYGPATH="cygpath -m" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_CYGPATH" && ac_cv_prog_CYGPATH="echo" fi ;; esac fi CYGPATH=$ac_cv_prog_CYGPATH if test -n "$CYGPATH"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CYGPATH" >&5 printf "%s\n" "$CYGPATH" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi EXEEXT=".exe" TEA_PLATFORM="windows" ;; *CYGWIN_*) EXEEXT=".exe" # CYGPATH and TEA_PLATFORM are determined later in LOAD_TCLCONFIG ;; *) CYGPATH=echo # Maybe we are cross-compiling.... case ${host_alias} in *mingw32*) EXEEXT=".exe" TEA_PLATFORM="windows" ;; *) EXEEXT="" TEA_PLATFORM="unix" ;; esac ;; esac # Check if exec_prefix is set. If not use fall back to prefix. # Note when adjusted, so that TEA_PREFIX can correct for this. # This is needed for recursive configures, since autoconf propagates # $prefix, but not $exec_prefix (doh!). if test x$exec_prefix = xNONE ; then exec_prefix_default=yes exec_prefix=$prefix fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: configuring ${PACKAGE_NAME} ${PACKAGE_VERSION}" >&5 printf "%s\n" "$as_me: configuring ${PACKAGE_NAME} ${PACKAGE_VERSION}" >&6;} # This package name must be replaced statically for AC_SUBST to work # We AC_SUBST these here to ensure they are subst'ed, # in case the user doesn't call TEA_ADD_... # Configure the installer. INSTALL='$(SHELL) $(srcdir)/tclconfig/install-sh -c' INSTALL_DATA_DIR='${INSTALL} -d -m 755' INSTALL_DATA='${INSTALL} -m 644' INSTALL_PROGRAM='${INSTALL} -m 755' INSTALL_SCRIPT='${INSTALL} -m 755' { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking system version" >&5 printf %s "checking system version... " >&6; } if test ${tcl_cv_sys_version+y} then : printf %s "(cached) " >&6 else case e in #( e) # TEA specific: if test "${TEA_PLATFORM}" = "windows" ; then tcl_cv_sys_version=windows else tcl_cv_sys_version=`uname -s`-`uname -r` if test "$?" -ne 0 ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5 printf "%s\n" "$as_me: WARNING: can't find uname command" >&2;} tcl_cv_sys_version=unknown else if test "`uname -s`" = "AIX" ; then tcl_cv_sys_version=AIX-`uname -v`.`uname -r` fi if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then tcl_cv_sys_version=NetBSD-Debian fi fi fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5 printf "%s\n" "$tcl_cv_sys_version" >&6; } system=$tcl_cv_sys_version case $system in HP-UX-*) INSTALL_LIBRARY='${INSTALL} -m 755' ;; *) INSTALL_LIBRARY='${INSTALL} -m 644' ;; esac #-------------------------------------------------------------------- # Load the tclConfig.sh file #-------------------------------------------------------------------- # # Ok, lets find the tcl configuration # First, look for one uninstalled. # the alternative search directory is invoked by --with-tcl # if test x"${no_tcl}" = x ; then # we reset no_tcl in case something fails here no_tcl=true # Check whether --with-tcl was given. if test ${with_tcl+y} then : withval=$with_tcl; with_tclconfig="${withval}" fi # Check whether --with-tcl8 was given. if test ${with_tcl8+y} then : withval=$with_tcl8; with_tcl8="${withval}" fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Tcl configuration" >&5 printf %s "checking for Tcl configuration... " >&6; } if test ${ac_cv_c_tclconfig+y} then : printf %s "(cached) " >&6 else case e in #( e) # First check to see if --with-tcl was specified. if test x"${with_tclconfig}" != x ; then case "${with_tclconfig}" in */tclConfig.sh ) if test -f "${with_tclconfig}"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: --with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself" >&5 printf "%s\n" "$as_me: WARNING: --with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself" >&2;} with_tclconfig="`echo "${with_tclconfig}" | sed 's!/tclConfig\.sh$!!'`" fi ;; esac if test -f "${with_tclconfig}/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd "${with_tclconfig}"; pwd)`" else as_fn_error $? "${with_tclconfig} directory doesn't contain tclConfig.sh" "$LINENO" 5 fi fi # then check for a private Tcl installation if test x"${ac_cv_c_tclconfig}" = x ; then for i in \ ../tcl \ `ls -dr ../tcl[8-9].[0-9].[0-9]* 2>/dev/null` \ `ls -dr ../tcl[8-9].[0-9] 2>/dev/null` \ `ls -dr ../tcl[8-9].[0-9]* 2>/dev/null` \ ../../tcl \ `ls -dr ../../tcl[8-9].[0-9].[0-9]* 2>/dev/null` \ `ls -dr ../../tcl[8-9].[0-9] 2>/dev/null` \ `ls -dr ../../tcl[8-9].[0-9]* 2>/dev/null` \ ../../../tcl \ `ls -dr ../../../tcl[8-9].[0-9].[0-9]* 2>/dev/null` \ `ls -dr ../../../tcl[8-9].[0-9] 2>/dev/null` \ `ls -dr ../../../tcl[8-9].[0-9]* 2>/dev/null` ; do if test "${TEA_PLATFORM}" = "windows" \ -a -f "$i/win/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/win; pwd)`" break fi if test -f "$i/unix/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" break fi done fi # on Darwin, check in Framework installation locations if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/Library/Frameworks/Tcl.framework 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/Network/Library/Frameworks/Tcl.framework 2>/dev/null` \ `ls -d /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/System/Library/Frameworks/Tcl.framework 2>/dev/null` \ ; do if test -f "$i/Tcl.framework/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/Tcl.framework; pwd)`" break fi done fi # TEA specific: on Windows, check in common installation locations if test "${TEA_PLATFORM}" = "windows" \ -a x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d C:/Tcl/lib 2>/dev/null` \ `ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i; pwd)`" break fi done fi # check in a few common install locations if test x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d ${libdir} 2>/dev/null` \ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/pkg/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ `ls -d /usr/lib/tcl9.0 2>/dev/null` \ `ls -d /usr/lib/tcl8.7 2>/dev/null` \ `ls -d /usr/lib/tcl8.6 2>/dev/null` \ `ls -d /usr/lib/tcl8.5 2>/dev/null` \ `ls -d /usr/local/lib/tcl9.0 2>/dev/null` \ `ls -d /usr/local/lib/tcl8.7 2>/dev/null` \ `ls -d /usr/local/lib/tcl8.6 2>/dev/null` \ `ls -d /usr/local/lib/tcl8.5 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl9.0 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl8.7 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl8.6 2>/dev/null` \ `ls -d /usr/local/lib/tcl/tcl8.5 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i; pwd)`" break fi done fi # check in a few other private locations if test x"${ac_cv_c_tclconfig}" = x ; then for i in \ ${srcdir}/../tcl \ `ls -dr ${srcdir}/../tcl[8-9].[0-9].[0-9]* 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[8-9].[0-9] 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[8-9].[0-9]* 2>/dev/null` ; do if test "${TEA_PLATFORM}" = "windows" \ -a -f "$i/win/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/win; pwd)`" break fi if test -f "$i/unix/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" break fi done fi ;; esac fi if test x"${ac_cv_c_tclconfig}" = x ; then TCL_BIN_DIR="# no Tcl configs found" as_fn_error $? "Can't find Tcl configuration definitions. Use --with-tcl to specify a directory containing tclConfig.sh" "$LINENO" 5 else no_tcl= TCL_BIN_DIR="${ac_cv_c_tclconfig}" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found ${TCL_BIN_DIR}/tclConfig.sh" >&5 printf "%s\n" "found ${TCL_BIN_DIR}/tclConfig.sh" >&6; } fi fi if test x"${with_tcl8}" != x; then with_tcl8="" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: --with-tcl8 option ignored" >&5 printf "%s\n" "$as_me: WARNING: --with-tcl8 option ignored" >&2;} fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then if test "$as_dir$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@" fi fi fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl.exe do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl.exe do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args. set dummy ${ac_tool_prefix}clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}clang" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "clang", so it can be a program name with args. set dummy clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="clang" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi fi test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH See 'config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion -version; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 printf %s "checking whether the C compiler works... " >&6; } ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { { ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : # Autoconf-2.13 could set the ac_cv_exeext variable to 'no'. # So ignore a value of 'no', otherwise this would lead to 'EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an '-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else case e in #( e) ac_file='' ;; esac fi if test -z "$ac_file" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables See 'config.log' for more details" "$LINENO" 5; } else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 printf %s "checking for C compiler default output file name... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 printf "%s\n" "$ac_file" >&6; } ac_exeext=$ac_cv_exeext rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 printf %s "checking for suffix of executables... " >&6; } if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : # If both 'conftest.exe' and 'conftest' are 'present' (well, observable) # catch 'conftest.exe'. For instance with Cygwin, 'ls conftest' will # work properly (i.e., refer to 'conftest.exe'), while it won't with # 'rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else case e in #( e) { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link See 'config.log' for more details" "$LINENO" 5; } ;; esac fi rm -f conftest conftest$ac_cv_exeext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 printf "%s\n" "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { FILE *f = fopen ("conftest.out", "w"); if (!f) return 1; return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF ac_clean_files="$ac_clean_files conftest.out" # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 printf %s "checking whether we are cross compiling... " >&6; } if test "$cross_compiling" != yes; then { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if { ac_try='./conftest$ac_cv_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error 77 "cannot run C compiled programs. If you meant to cross compile, use '--host'. See 'config.log' for more details" "$LINENO" 5; } fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 printf "%s\n" "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext \ conftest.o conftest.obj conftest.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 printf %s "checking for suffix of object files... " >&6; } if test ${ac_cv_objext+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else case e in #( e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile See 'config.log' for more details" "$LINENO" 5; } ;; esac fi rm -f conftest.$ac_cv_objext conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 printf "%s\n" "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5 printf %s "checking whether the compiler supports GNU C... " >&6; } if test ${ac_cv_c_compiler_gnu+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_compiler_gnu=yes else case e in #( e) ac_compiler_gnu=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; } ac_compiler_gnu=$ac_cv_c_compiler_gnu if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+y} ac_save_CFLAGS=$CFLAGS { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 printf %s "checking whether $CC accepts -g... " >&6; } if test ${ac_cv_prog_cc_g+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes else case e in #( e) CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : else case e in #( e) ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 printf "%s\n" "$ac_cv_prog_cc_g" >&6; } if test $ac_test_CFLAGS; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi ac_prog_cc_stdc=no if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5 printf %s "checking for $CC option to enable C11 features... " >&6; } if test ${ac_cv_prog_cc_c11+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_cv_prog_cc_c11=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c11_program _ACEOF for ac_arg in '' -std=gnu11 do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c11=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c11" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC ;; esac fi if test "x$ac_cv_prog_cc_c11" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else case e in #( e) if test "x$ac_cv_prog_cc_c11" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } CC="$CC $ac_cv_prog_cc_c11" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 ac_prog_cc_stdc=c11 ;; esac fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5 printf %s "checking for $CC option to enable C99 features... " >&6; } if test ${ac_cv_prog_cc_c99+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_cv_prog_cc_c99=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c99_program _ACEOF for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99= do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c99=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c99" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC ;; esac fi if test "x$ac_cv_prog_cc_c99" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else case e in #( e) if test "x$ac_cv_prog_cc_c99" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } CC="$CC $ac_cv_prog_cc_c99" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 ac_prog_cc_stdc=c99 ;; esac fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5 printf %s "checking for $CC option to enable C89 features... " >&6; } if test ${ac_cv_prog_cc_c89+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c89_program _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c89=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC ;; esac fi if test "x$ac_cv_prog_cc_c89" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else case e in #( e) if test "x$ac_cv_prog_cc_c89" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } CC="$CC $ac_cv_prog_cc_c89" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 ac_prog_cc_stdc=c89 ;; esac fi fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for existence of ${TCL_BIN_DIR}/tclConfig.sh" >&5 printf %s "checking for existence of ${TCL_BIN_DIR}/tclConfig.sh... " >&6; } if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: loading" >&5 printf "%s\n" "loading" >&6; } . "${TCL_BIN_DIR}/tclConfig.sh" else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: could not find ${TCL_BIN_DIR}/tclConfig.sh" >&5 printf "%s\n" "could not find ${TCL_BIN_DIR}/tclConfig.sh" >&6; } fi # If the TCL_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable TCL_LIB_SPEC will be set to the value # of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC # instead of TCL_BUILD_LIB_SPEC since it will work with both an # installed and uninstalled version of Tcl. if test -f "${TCL_BIN_DIR}/Makefile" ; then TCL_LIB_SPEC="${TCL_BUILD_LIB_SPEC}" TCL_STUB_LIB_SPEC="${TCL_BUILD_STUB_LIB_SPEC}" TCL_STUB_LIB_PATH="${TCL_BUILD_STUB_LIB_PATH}" elif test "`uname -s`" = "Darwin"; then # If Tcl was built as a framework, attempt to use the libraries # from the framework at the given location so that linking works # against Tcl.framework installed in an arbitrary location. case ${TCL_DEFS} in *TCL_FRAMEWORK*) if test -f "${TCL_BIN_DIR}/${TCL_LIB_FILE}"; then for i in "`cd "${TCL_BIN_DIR}"; pwd`" \ "`cd "${TCL_BIN_DIR}"/../..; pwd`"; do if test "`basename "$i"`" = "${TCL_LIB_FILE}.framework"; then TCL_LIB_SPEC="-F`dirname "$i" | sed -e 's/ /\\\\ /g'` -framework ${TCL_LIB_FILE}" break fi done fi if test -f "${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}"; then TCL_STUB_LIB_SPEC="-L`echo "${TCL_BIN_DIR}" | sed -e 's/ /\\\\ /g'` ${TCL_STUB_LIB_FLAG}" TCL_STUB_LIB_PATH="${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}" fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking platform" >&5 printf %s "checking platform... " >&6; } hold_cc=$CC; CC="$TCL_CC" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { #ifdef _WIN32 #error win32 #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : # first test we've already retrieved platform (cross-compile), fallback to unix otherwise: TEA_PLATFORM="${TEA_PLATFORM-unix}" CYGPATH=echo else case e in #( e) TEA_PLATFORM="windows" # Extract the first word of "cygpath", so it can be a program name with args. set dummy cygpath; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CYGPATH+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CYGPATH"; then ac_cv_prog_CYGPATH="$CYGPATH" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CYGPATH="cygpath -m" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_CYGPATH" && ac_cv_prog_CYGPATH="echo" fi ;; esac fi CYGPATH=$ac_cv_prog_CYGPATH if test -n "$CYGPATH"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CYGPATH" >&5 printf "%s\n" "$CYGPATH" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext CC=$hold_cc { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $TEA_PLATFORM" >&5 printf "%s\n" "$TEA_PLATFORM" >&6; } # The BUILD_$pkg is to define the correct extern storage class # handling when making this package printf "%s\n" "#define BUILD_${PACKAGE_NAME} /**/" >>confdefs.h # Do this here as we have fully defined TEA_PLATFORM now if test "${TEA_PLATFORM}" = "windows" ; then EXEEXT=".exe" CLEANFILES="$CLEANFILES *.lib *.dll *.pdb *.exp" fi # TEA specific: if test "${TCL_MAJOR_VERSION}" -eq 8; then as_fn_error $? "${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 9.0+ Found config for Tcl ${TCL_VERSION}" "$LINENO" 5 fi #-------------------------------------------------------------------- # Load the tkConfig.sh file if necessary (Tk extension) #-------------------------------------------------------------------- #TEA_PATH_TKCONFIG #TEA_LOAD_TKCONFIG #----------------------------------------------------------------------- # Handle the --prefix=... option by defaulting to what Tcl gave. # Must be called after TEA_LOAD_TCLCONFIG and before TEA_SETUP_COMPILER. #----------------------------------------------------------------------- if test "${prefix}" = "NONE"; then prefix_default=yes if test x"${TCL_PREFIX}" != x; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: --prefix defaulting to TCL_PREFIX ${TCL_PREFIX}" >&5 printf "%s\n" "$as_me: --prefix defaulting to TCL_PREFIX ${TCL_PREFIX}" >&6;} prefix=${TCL_PREFIX} else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: --prefix defaulting to /usr/local" >&5 printf "%s\n" "$as_me: --prefix defaulting to /usr/local" >&6;} prefix=/usr/local fi fi if test "${exec_prefix}" = "NONE" -a x"${prefix_default}" = x"yes" \ -o x"${exec_prefix_default}" = x"yes" ; then if test x"${TCL_EXEC_PREFIX}" != x; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: --exec-prefix defaulting to TCL_EXEC_PREFIX ${TCL_EXEC_PREFIX}" >&5 printf "%s\n" "$as_me: --exec-prefix defaulting to TCL_EXEC_PREFIX ${TCL_EXEC_PREFIX}" >&6;} exec_prefix=${TCL_EXEC_PREFIX} else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: --exec-prefix defaulting to ${prefix}" >&5 printf "%s\n" "$as_me: --exec-prefix defaulting to ${prefix}" >&6;} exec_prefix=$prefix fi fi #----------------------------------------------------------------------- # Standard compiler checks. # This sets up CC by using the CC env var, or looks for gcc otherwise. # This also calls AC_PROG_CC and a few others to create the basic setup # necessary to compile executables. #----------------------------------------------------------------------- # Don't put any macros that use the compiler (e.g. AC_TRY_COMPILE) # in this macro, they need to go into TEA_SETUP_COMPILER instead. ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then if test "$as_dir$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@" fi fi fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl.exe do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl.exe do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args. set dummy ${ac_tool_prefix}clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}clang" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "clang", so it can be a program name with args. set dummy clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="clang" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi fi test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH See 'config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion -version; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5 printf %s "checking whether the compiler supports GNU C... " >&6; } if test ${ac_cv_c_compiler_gnu+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_compiler_gnu=yes else case e in #( e) ac_compiler_gnu=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; } ac_compiler_gnu=$ac_cv_c_compiler_gnu if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+y} ac_save_CFLAGS=$CFLAGS { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 printf %s "checking whether $CC accepts -g... " >&6; } if test ${ac_cv_prog_cc_g+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes else case e in #( e) CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : else case e in #( e) ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 printf "%s\n" "$ac_cv_prog_cc_g" >&6; } if test $ac_test_CFLAGS; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi ac_prog_cc_stdc=no if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5 printf %s "checking for $CC option to enable C11 features... " >&6; } if test ${ac_cv_prog_cc_c11+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_cv_prog_cc_c11=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c11_program _ACEOF for ac_arg in '' -std=gnu11 do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c11=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c11" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC ;; esac fi if test "x$ac_cv_prog_cc_c11" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else case e in #( e) if test "x$ac_cv_prog_cc_c11" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } CC="$CC $ac_cv_prog_cc_c11" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 ac_prog_cc_stdc=c11 ;; esac fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5 printf %s "checking for $CC option to enable C99 features... " >&6; } if test ${ac_cv_prog_cc_c99+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_cv_prog_cc_c99=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c99_program _ACEOF for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99= do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c99=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c99" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC ;; esac fi if test "x$ac_cv_prog_cc_c99" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else case e in #( e) if test "x$ac_cv_prog_cc_c99" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } CC="$CC $ac_cv_prog_cc_c99" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 ac_prog_cc_stdc=c99 ;; esac fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5 printf %s "checking for $CC option to enable C89 features... " >&6; } if test ${ac_cv_prog_cc_c89+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c89_program _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c89=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC ;; esac fi if test "x$ac_cv_prog_cc_c89" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else case e in #( e) if test "x$ac_cv_prog_cc_c89" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } CC="$CC $ac_cv_prog_cc_c89" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 ac_prog_cc_stdc=c89 ;; esac fi fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 printf %s "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if test ${ac_cv_prog_CPP+y} then : printf %s "(cached) " >&6 else case e in #( e) # Double quotes because $CC needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" cpp /lib/cpp do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO" then : else case e in #( e) # Broken: fails on valid input. continue ;; esac fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO" then : # Broken: success on invalid input. continue else case e in #( e) # Passes both tests. ac_preproc_ok=: break ;; esac fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of 'break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok then : break fi done ac_cv_prog_CPP=$CPP ;; esac fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 printf "%s\n" "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO" then : else case e in #( e) # Broken: fails on valid input. continue ;; esac fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO" then : # Broken: success on invalid input. continue else case e in #( e) # Passes both tests. ac_preproc_ok=: break ;; esac fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of 'break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok then : else case e in #( e) { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check See 'config.log' for more details" "$LINENO" 5; } ;; esac fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu #-------------------------------------------------------------------- # Checks to see if the make program sets the $MAKE variable. #-------------------------------------------------------------------- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 printf %s "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } set x ${MAKE-make} ac_make=`printf "%s\n" "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` if eval test \${ac_cv_prog_make_${ac_make}_set+y} then : printf %s "(cached) " >&6 else case e in #( e) cat >conftest.make <<\_ACEOF SHELL = /bin/sh all: @echo '@@@%%%=$(MAKE)=@@@%%%' _ACEOF # GNU make sometimes prints "make[1]: Entering ...", which would confuse us. case `${MAKE-make} -f conftest.make 2>/dev/null` in *@@@%%%=?*=@@@%%%*) eval ac_cv_prog_make_${ac_make}_set=yes;; *) eval ac_cv_prog_make_${ac_make}_set=no;; esac rm -f conftest.make ;; esac fi if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } SET_MAKE= else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } SET_MAKE="MAKE=${MAKE-make}" fi #-------------------------------------------------------------------- # Find ranlib #-------------------------------------------------------------------- if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. set dummy ${ac_tool_prefix}ranlib; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_RANLIB+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi RANLIB=$ac_cv_prog_RANLIB if test -n "$RANLIB"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 printf "%s\n" "$RANLIB" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_RANLIB"; then ac_ct_RANLIB=$RANLIB # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_RANLIB+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_RANLIB"; then ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_RANLIB="ranlib" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB if test -n "$ac_ct_RANLIB"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 printf "%s\n" "$ac_ct_RANLIB" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_RANLIB" = x; then RANLIB="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac RANLIB=$ac_ct_RANLIB fi else RANLIB="$ac_cv_prog_RANLIB" fi #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- ac_header= ac_cache= for ac_item in $ac_header_c_list do if test $ac_cache; then ac_fn_c_check_header_compile "$LINENO" $ac_header ac_cv_header_$ac_cache "$ac_includes_default" if eval test \"x\$ac_cv_header_$ac_cache\" = xyes; then printf "%s\n" "#define $ac_item 1" >> confdefs.h fi ac_header= ac_cache= elif test $ac_header; then ac_cache=$ac_item else ac_header=$ac_item fi done if test $ac_cv_header_stdlib_h = yes && test $ac_cv_header_string_h = yes then : printf "%s\n" "#define STDC_HEADERS 1" >>confdefs.h fi # Any macros that use the compiler (e.g. AC_TRY_COMPILE) have to go here. #------------------------------------------------------------------------ # If we're using GCC, see if the compiler understands -pipe. If so, use it. # It makes compiling go faster. (This is only a performance feature.) #------------------------------------------------------------------------ if test -z "$no_pipe" -a -n "$GCC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if the compiler understands -pipe" >&5 printf %s "checking if the compiler understands -pipe... " >&6; } if test ${tcl_cv_cc_pipe+y} then : printf %s "(cached) " >&6 else case e in #( e) hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -pipe" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_cc_pipe=yes else case e in #( e) tcl_cv_cc_pipe=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext CFLAGS=$hold_cflags ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_pipe" >&5 printf "%s\n" "$tcl_cv_cc_pipe" >&6; } if test $tcl_cv_cc_pipe = yes; then CFLAGS="$CFLAGS -pipe" fi fi if test "${TCL_MAJOR_VERSION}" -lt 9 -a "${TCL_MINOR_VERSION}" -lt 7; then printf "%s\n" "#define Tcl_Size int" >>confdefs.h fi #-------------------------------------------------------------------- # Common compiler flag setup #-------------------------------------------------------------------- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether byte ordering is bigendian" >&5 printf %s "checking whether byte ordering is bigendian... " >&6; } if test ${ac_cv_c_bigendian+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_cv_c_bigendian=unknown # See if we're dealing with a universal compiler. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifndef __APPLE_CC__ not a universal capable compiler #endif typedef int dummy; _ACEOF if ac_fn_c_try_compile "$LINENO" then : # Check for potential -arch flags. It is not universal unless # there are at least two -arch flags with different values. ac_arch= ac_prev= for ac_word in $CC $CFLAGS $CPPFLAGS $LDFLAGS; do if test -n "$ac_prev"; then case $ac_word in i?86 | x86_64 | ppc | ppc64) if test -z "$ac_arch" || test "$ac_arch" = "$ac_word"; then ac_arch=$ac_word else ac_cv_c_bigendian=universal break fi ;; esac ac_prev= elif test "x$ac_word" = "x-arch"; then ac_prev=arch fi done fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext if test $ac_cv_c_bigendian = unknown; then # See if sys/param.h defines the BYTE_ORDER macro. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { #if ! (defined BYTE_ORDER && defined BIG_ENDIAN \\ && defined LITTLE_ENDIAN && BYTE_ORDER && BIG_ENDIAN \\ && LITTLE_ENDIAN) bogus endian macros #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : # It does; now see whether it defined to BIG_ENDIAN or not. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { #if BYTE_ORDER != BIG_ENDIAN not big endian #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_c_bigendian=yes else case e in #( e) ac_cv_c_bigendian=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi if test $ac_cv_c_bigendian = unknown; then # See if defines _LITTLE_ENDIAN or _BIG_ENDIAN (e.g., Solaris). cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { #if ! (defined _LITTLE_ENDIAN || defined _BIG_ENDIAN) bogus endian macros #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : # It does; now see whether it defined to _BIG_ENDIAN or not. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { #ifndef _BIG_ENDIAN not big endian #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_c_bigendian=yes else case e in #( e) ac_cv_c_bigendian=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi if test $ac_cv_c_bigendian = unknown; then # Compile a test program. if test "$cross_compiling" = yes then : # Try to guess by grepping values from an object file. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ unsigned short int ascii_mm[] = { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 }; unsigned short int ascii_ii[] = { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 }; int use_ascii (int i) { return ascii_mm[i] + ascii_ii[i]; } unsigned short int ebcdic_ii[] = { 0x89D3, 0xE3E3, 0x8593, 0x95C5, 0x89C4, 0x9581, 0 }; unsigned short int ebcdic_mm[] = { 0xC2C9, 0xC785, 0x95C4, 0x8981, 0x95E2, 0xA8E2, 0 }; int use_ebcdic (int i) { return ebcdic_mm[i] + ebcdic_ii[i]; } int main (int argc, char **argv) { /* Intimidate the compiler so that it does not optimize the arrays away. */ char *p = argv[0]; ascii_mm[1] = *p++; ebcdic_mm[1] = *p++; ascii_ii[1] = *p++; ebcdic_ii[1] = *p++; return use_ascii (argc) == use_ebcdic (*p); } _ACEOF if ac_fn_c_try_link "$LINENO" then : if grep BIGenDianSyS conftest$ac_exeext >/dev/null; then ac_cv_c_bigendian=yes fi if grep LiTTleEnDian conftest$ac_exeext >/dev/null ; then if test "$ac_cv_c_bigendian" = unknown; then ac_cv_c_bigendian=no else # finding both strings is unlikely to happen, but who knows? ac_cv_c_bigendian=unknown fi fi fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int main (void) { /* Are we little or big endian? From Harbison&Steele. */ union { long int l; char c[sizeof (long int)]; } u; u.l = 1; return u.c[sizeof (long int) - 1] == 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : ac_cv_c_bigendian=no else case e in #( e) ac_cv_c_bigendian=yes ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_bigendian" >&5 printf "%s\n" "$ac_cv_c_bigendian" >&6; } case $ac_cv_c_bigendian in #( yes) printf "%s\n" "#define WORDS_BIGENDIAN 1" >>confdefs.h ;; #( no) ;; #( universal) # ;; #( *) as_fn_error $? "unknown endianness presetting ac_cv_c_bigendian=no (or yes) will help" "$LINENO" 5 ;; esac #-------------------------------------------------------------------- # Check if building with optional Gdbm package. This will declare # GDBM_CFLAGS and GDBM_LIBS variables. #-------------------------------------------------------------------- # Check whether --with-gdbm was given. if test ${with_gdbm+y} then : withval=$with_gdbm; \ with_gdbm=${withval} fi if test x"${with_gdbm}" != x -a "${with_gdbm}" != no; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for GNU gdbm library" >&5 printf %s "checking for GNU gdbm library... " >&6; } if test ${ac_cv_c_gdbm+y} then : printf %s "(cached) " >&6 else case e in #( e) if test x"${with_gdbm}" != x -a "${with_gdbm}" != "yes"; then if test -f "${with_gdbm}/gdbm.h" -a x"`ls ${with_gdbm}/libgdbm* 2>/dev/null`" != x; then ac_cv_c_gdbm=`(cd ${with_gdbm}; pwd)` gincdir=$ac_cv_c_gdbm glibdir=$ac_cv_c_gdbm { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found in $glibdir" >&5 printf "%s\n" "found in $glibdir" >&6; } else as_fn_error $? "${with_gdbm} directory doesn't contain gdbm library" "$LINENO" 5 fi fi ;; esac fi if test x"${gincdir}" = x -o x"${glibdir}" = x; then for i in \ `ls -d ${exec_prefix}/lib 2>/dev/null`\ `ls -d ${prefix}/lib 2>/dev/null`\ `ls -d /usr/local/lib 2>/dev/null`\ `ls -d /usr/lib 2>/dev/null`\ `ls -d /usr/lib/x86_64-linux-gnu 2>/dev/null` ; do if test x"`ls $i/libgdbm* 2>/dev/null`" != x ; then glibdir=`(cd $i; pwd)` break fi done for i in \ `ls -d ${prefix}/include 2>/dev/null`\ `ls -d /usr/local/include 2>/dev/null`\ `ls -d /usr/include 2>/dev/null` ; do if test -f "$i/gdbm.h" ; then gincdir=`(cd $i; pwd)` break fi done if test x"$glibdir" = x -o x"$gincdir" = x ; then as_fn_error $? "none found" "$LINENO" 5 else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found in $glibdir, includes in $gincdir" >&5 printf "%s\n" "found in $glibdir, includes in $gincdir" >&6; } printf "%s\n" "#define HAVE_GDBM 1" >>confdefs.h GDBM_CFLAGS="-I\"$gincdir\"" GDBM_LIBS="-L\"$glibdir\" -lgdbm" fi fi fi #-------------------------------------------------------------------- # Check if building with optional lmdb package. This will declare # LMDB_CFLAGS and LMDB_LIBS variables. #-------------------------------------------------------------------- # Check whether --with-lmdb was given. if test ${with_lmdb+y} then : withval=$with_lmdb; with_lmdb=${withval} fi if test x"${with_lmdb}" != "x" -a "${with_lmdb}" != no; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for LMDB library" >&5 printf %s "checking for LMDB library... " >&6; } if test ${ac_cv_c_lmdb+y} then : printf %s "(cached) " >&6 else case e in #( e) if test x"${with_lmdb}" != x -a "${with_lmdb}" != "yes"; then if test -f "${with_lmdb}/lmdb.h" -a x"`ls ${with_lmdb}/liblmdb* 2>/dev/null`" != x; then ac_cv_c_lmdb=`(cd ${with_lmdb}; pwd)` lincdir=$ac_cv_c_lmdb llibdir=$ac_cv_c_lmdb { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found in $llibdir" >&5 printf "%s\n" "found in $llibdir" >&6; } else as_fn_error $? "${with_lmdb} directory doesn't contain lmdb library" "$LINENO" 5 fi fi ;; esac fi if test x"${lincdir}" = x -o x"${llibdir}" = x; then for i in \ `ls -d ${exec_prefix}/lib 2>/dev/null`\ `ls -d ${prefix}/lib 2>/dev/null`\ `ls -d /usr/local/lib 2>/dev/null`\ `ls -d /usr/lib 2>/dev/null`\ `ls -d /usr/lib/x86_64-linux-gnu 2>/dev/null` ; do if test x"`ls $i/liblmdb* 2>/dev/null`" != x ; then llibdir=`(cd $i; pwd)` break fi done for i in \ `ls -d ${prefix}/include 2>/dev/null`\ `ls -d /usr/local/include 2>/dev/null`\ `ls -d /usr/include 2>/dev/null` ; do if test -f "$i/lmdb.h" ; then lincdir=`(cd $i; pwd)` break fi done if test x"$llibdir" = x -o x"$lincdir" = x ; then as_fn_error $? "none found" "$LINENO" 5 else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found in $llibdir, includes in $lincdir" >&5 printf "%s\n" "found in $llibdir, includes in $lincdir" >&6; } printf "%s\n" "#define HAVE_LMDB 1" >>confdefs.h LMDB_CFLAGS="-I\"$lincdir\"" LMDB_LIBS="-L\"$llibdir\" -llmdb" fi fi fi #-------------------------------------------------------------------- # Locate the NaviServer/AOLserver dir for compilation as NaviServer/AOLserver module. # This will declare NS_INCLUDES, NS_LIBS and define NS_AOLSERVER. #-------------------------------------------------------------------- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for NaviServer/AOLserver configuration" >&5 printf %s "checking for NaviServer/AOLserver configuration... " >&6; } # Check whether --with-naviserver was given. if test ${with_naviserver+y} then : withval=$with_naviserver; \ with_naviserver=${withval} fi if test ${ac_cv_c_naviserver+y} then : printf %s "(cached) " >&6 else case e in #( e) if test x"${with_naviserver}" != x ; then if test -f "${with_naviserver}/include/ns.h" ; then ac_cv_c_naviserver=`(cd ${with_naviserver}; pwd)` else as_fn_error $? "${with_naviserver} directory doesn't contain ns.h" "$LINENO" 5 fi fi ;; esac fi if test x"${ac_cv_c_naviserver}" = x ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none found" >&5 printf "%s\n" "none found" >&6; } else NS_DIR=${ac_cv_c_naviserver} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: found NaviServer/AOLserver in $NS_DIR" >&5 printf "%s\n" "found NaviServer/AOLserver in $NS_DIR" >&6; } NS_INCLUDES="-I\"${NS_DIR}/include\"" if test "`uname -s`" = Darwin ; then aollibs=`ls ${NS_DIR}/lib/libns* 2>/dev/null` if test x"$aollibs" != x ; then NS_LIBS="-L\"${NS_DIR}/lib\" -lnsd -lnsthread" fi fi printf "%s\n" "#define NS_AOLSERVER 1" >>confdefs.h fi #----------------------------------------------------------------------- # __CHANGE__ # Specify the C source files to compile in TEA_ADD_SOURCES, # public headers that need to be installed in TEA_ADD_HEADERS, # stub library C source files to compile in TEA_ADD_STUB_SOURCES, # and runtime Tcl library files in TEA_ADD_TCL_SOURCES. # This defines PKG(_STUB)_SOURCES, PKG(_STUB)_OBJECTS, PKG_HEADERS # and PKG_TCL_SOURCES. #----------------------------------------------------------------------- vars="generic/threadNs.c \ generic/threadCmd.c \ generic/threadSvCmd.c \ generic/threadSpCmd.c \ generic/threadPoolCmd.c \ generic/psGdbm.c \ generic/psLmdb.c \ generic/threadSvListCmd.c \ generic/threadSvKeylistCmd.c \ generic/tclXkeylist.c \ " for i in $vars; do case $i in \$*) # allow $-var names PKG_SOURCES="$PKG_SOURCES $i" PKG_OBJECTS="$PKG_OBJECTS $i" ;; *) # check for existence - allows for generic/win/unix VPATH # To add more dirs here (like 'src'), you have to update VPATH # in Makefile.in as well if test ! -f "${srcdir}/$i" -a ! -f "${srcdir}/generic/$i" \ -a ! -f "${srcdir}/win/$i" -a ! -f "${srcdir}/unix/$i" \ -a ! -f "${srcdir}/macosx/$i" \ ; then as_fn_error $? "could not find source file '$i'" "$LINENO" 5 fi PKG_SOURCES="$PKG_SOURCES $i" # this assumes it is in a VPATH dir i=`basename $i` # handle user calling this before or after TEA_SETUP_COMPILER if test x"${OBJEXT}" != x ; then j="`echo $i | sed -e 's/\.[^.]*$//'`.${OBJEXT}" else j="`echo $i | sed -e 's/\.[^.]*$//'`.\${OBJEXT}" fi PKG_OBJECTS="$PKG_OBJECTS $j" ;; esac done vars="generic/tclThread.h" for i in $vars; do # check for existence, be strict because it is installed if test ! -f "${srcdir}/$i" ; then as_fn_error $? "could not find header file '${srcdir}/$i'" "$LINENO" 5 fi PKG_HEADERS="$PKG_HEADERS $i" done vars="${NS_INCLUDES}" for i in $vars; do PKG_INCLUDES="$PKG_INCLUDES $i" done vars="${GDBM_LIBS} ${LMDB_LIBS} ${NS_LIBS}" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then # Convert foo.lib to -lfoo for GCC. No-op if not *.lib i=`echo "$i" | sed -e 's/^\([^-].*\)\.[lL][iI][bB]$/-l\1/'` fi PKG_LIBS="$PKG_LIBS $i" done PKG_CFLAGS="$PKG_CFLAGS ${GDBM_CFLAGS} ${LMDB_CFLAGS}" vars="" for i in $vars; do # check for existence - allows for generic/win/unix VPATH if test ! -f "${srcdir}/$i" -a ! -f "${srcdir}/generic/$i" \ -a ! -f "${srcdir}/win/$i" -a ! -f "${srcdir}/unix/$i" \ -a ! -f "${srcdir}/macosx/$i" \ ; then as_fn_error $? "could not find stub source file '$i'" "$LINENO" 5 fi PKG_STUB_SOURCES="$PKG_STUB_SOURCES $i" # this assumes it is in a VPATH dir i=`basename $i` # handle user calling this before or after TEA_SETUP_COMPILER if test x"${OBJEXT}" != x ; then j="`echo $i | sed -e 's/\.[^.]*$//'`.${OBJEXT}" else j="`echo $i | sed -e 's/\.[^.]*$//'`.\${OBJEXT}" fi PKG_STUB_OBJECTS="$PKG_STUB_OBJECTS $j" done vars="lib/ttrace.tcl" for i in $vars; do # check for existence, be strict because it is installed if test ! -f "${srcdir}/$i" ; then as_fn_error $? "could not find tcl source file '${srcdir}/$i'" "$LINENO" 5 fi PKG_TCL_SOURCES="$PKG_TCL_SOURCES $i" done #-------------------------------------------------------------------- # __CHANGE__ # A few miscellaneous platform-specific items: # # Define a special symbol for Windows (BUILD_sample in this case) so # that we create the export library with the dll. # # Windows creates a few extra files that need to be cleaned up. # You can add more files to clean if your extension creates any extra # files. # # TEA_ADD_* any platform specific compiler/build info here. #-------------------------------------------------------------------- if test "${TEA_PLATFORM}" = "windows" ; then vars="-I\"$(${CYGPATH} ${srcdir}/win)\"" for i in $vars; do PKG_INCLUDES="$PKG_INCLUDES $i" done else vars="unix/threadUnix.c" for i in $vars; do case $i in \$*) # allow $-var names PKG_SOURCES="$PKG_SOURCES $i" PKG_OBJECTS="$PKG_OBJECTS $i" ;; *) # check for existence - allows for generic/win/unix VPATH # To add more dirs here (like 'src'), you have to update VPATH # in Makefile.in as well if test ! -f "${srcdir}/$i" -a ! -f "${srcdir}/generic/$i" \ -a ! -f "${srcdir}/win/$i" -a ! -f "${srcdir}/unix/$i" \ -a ! -f "${srcdir}/macosx/$i" \ ; then as_fn_error $? "could not find source file '$i'" "$LINENO" 5 fi PKG_SOURCES="$PKG_SOURCES $i" # this assumes it is in a VPATH dir i=`basename $i` # handle user calling this before or after TEA_SETUP_COMPILER if test x"${OBJEXT}" != x ; then j="`echo $i | sed -e 's/\.[^.]*$//'`.${OBJEXT}" else j="`echo $i | sed -e 's/\.[^.]*$//'`.\${OBJEXT}" fi PKG_OBJECTS="$PKG_OBJECTS $j" ;; esac done fi #-------------------------------------------------------------------- # __CHANGE__ # Choose which headers you need. Extension authors should try very # hard to only rely on the Tcl public header files. Internal headers # contain private data structures and are subject to change without # notice. # This MUST be called after TEA_LOAD_TCLCONFIG / TEA_LOAD_TKCONFIG #-------------------------------------------------------------------- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Tcl public headers" >&5 printf %s "checking for Tcl public headers... " >&6; } # Check whether --with-tclinclude was given. if test ${with_tclinclude+y} then : withval=$with_tclinclude; with_tclinclude=${withval} fi if test ${ac_cv_c_tclh+y} then : printf %s "(cached) " >&6 else case e in #( e) # Use the value from --with-tclinclude, if it was given if test x"${with_tclinclude}" != x ; then if test -f "${with_tclinclude}/tcl.h" ; then ac_cv_c_tclh=${with_tclinclude} else as_fn_error $? "${with_tclinclude} directory does not contain tcl.h" "$LINENO" 5 fi else list="" if test "`uname -s`" = "Darwin"; then # If Tcl was built as a framework, attempt to use # the framework's Headers directory case ${TCL_DEFS} in *TCL_FRAMEWORK*) list="`ls -d ${TCL_BIN_DIR}/Headers 2>/dev/null`" ;; esac fi # Look in the source dir only if Tcl is not installed, # and in that situation, look there before installed locations. if test -f "${TCL_BIN_DIR}/Makefile" ; then list="$list `ls -d ${TCL_SRC_DIR}/generic 2>/dev/null`" fi # Check order: pkg --prefix location, Tcl's --prefix location, # relative to directory of tclConfig.sh. eval "temp_includedir=${includedir}" list="$list \ `ls -d ${temp_includedir} 2>/dev/null` \ `ls -d ${TCL_PREFIX}/include 2>/dev/null` \ `ls -d ${TCL_BIN_DIR}/../include 2>/dev/null`" if test "${TEA_PLATFORM}" != "windows" -o "$GCC" = "yes"; then list="$list /usr/local/include /usr/include" if test x"${TCL_INCLUDE_SPEC}" != x ; then d=`echo "${TCL_INCLUDE_SPEC}" | sed -e 's/^-I//'` list="$list `ls -d ${d} 2>/dev/null`" fi fi for i in $list ; do if test -f "$i/tcl.h" ; then ac_cv_c_tclh=$i break fi done fi ;; esac fi # Print a message based on how we determined the include path if test x"${ac_cv_c_tclh}" = x ; then as_fn_error $? "tcl.h not found. Please specify its location with --with-tclinclude" "$LINENO" 5 else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${ac_cv_c_tclh}" >&5 printf "%s\n" "${ac_cv_c_tclh}" >&6; } fi # Convert to a native path and substitute into the output files. INCLUDE_DIR_NATIVE=`${CYGPATH} ${ac_cv_c_tclh}` TCL_INCLUDES=-I\"${INCLUDE_DIR_NATIVE}\" #TEA_PRIVATE_TCL_HEADERS #TEA_PUBLIC_TK_HEADERS #TEA_PRIVATE_TK_HEADERS #TEA_PATH_X #-------------------------------------------------------------------- # Check whether --enable-threads or --disable-threads was given. # This auto-enables if Tcl was compiled threaded. #-------------------------------------------------------------------- # Check whether --enable-threads was given. if test ${enable_threads+y} then : enableval=$enable_threads; tcl_ok=$enableval else case e in #( e) tcl_ok=yes ;; esac fi if test "${enable_threads+set}" = set; then enableval="$enable_threads" tcl_ok=$enableval else tcl_ok=yes fi if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then TCL_THREADS=1 if test "${TEA_PLATFORM}" != "windows" ; then # We are always OK on Windows, so check what this platform wants: # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention printf "%s\n" "#define USE_THREAD_ALLOC 1" >>confdefs.h printf "%s\n" "#define _REENTRANT 1" >>confdefs.h if test "`uname -s`" = "SunOS" ; then printf "%s\n" "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h fi printf "%s\n" "#define _THREAD_SAFE 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthread" >&5 printf %s "checking for pthread_mutex_init in -lpthread... " >&6; } if test ${ac_cv_lib_pthread_pthread_mutex_init+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char pthread_mutex_init (void); int main (void) { return pthread_mutex_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_pthread_pthread_mutex_init=yes else case e in #( e) ac_cv_lib_pthread_pthread_mutex_init=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5 printf "%s\n" "$ac_cv_lib_pthread_pthread_mutex_init" >&6; } if test "x$ac_cv_lib_pthread_pthread_mutex_init" = xyes then : tcl_ok=yes else case e in #( e) tcl_ok=no ;; esac fi if test "$tcl_ok" = "no"; then # Check a little harder for __pthread_mutex_init in the same # library, as some systems hide it there until pthread.h is # defined. We could alternatively do an AC_TRY_COMPILE with # pthread.h, but that will work with libpthread really doesn't # exist, like AIX 4.2. [Bug: 4359] { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for __pthread_mutex_init in -lpthread" >&5 printf %s "checking for __pthread_mutex_init in -lpthread... " >&6; } if test ${ac_cv_lib_pthread___pthread_mutex_init+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char __pthread_mutex_init (void); int main (void) { return __pthread_mutex_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_pthread___pthread_mutex_init=yes else case e in #( e) ac_cv_lib_pthread___pthread_mutex_init=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5 printf "%s\n" "$ac_cv_lib_pthread___pthread_mutex_init" >&6; } if test "x$ac_cv_lib_pthread___pthread_mutex_init" = xyes then : tcl_ok=yes else case e in #( e) tcl_ok=no ;; esac fi fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthread" else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthreads" >&5 printf %s "checking for pthread_mutex_init in -lpthreads... " >&6; } if test ${ac_cv_lib_pthreads_pthread_mutex_init+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_check_lib_save_LIBS=$LIBS LIBS="-lpthreads $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char pthread_mutex_init (void); int main (void) { return pthread_mutex_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_pthreads_pthread_mutex_init=yes else case e in #( e) ac_cv_lib_pthreads_pthread_mutex_init=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5 printf "%s\n" "$ac_cv_lib_pthreads_pthread_mutex_init" >&6; } if test "x$ac_cv_lib_pthreads_pthread_mutex_init" = xyes then : tcl_ok=yes else case e in #( e) tcl_ok=no ;; esac fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthreads" else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc" >&5 printf %s "checking for pthread_mutex_init in -lc... " >&6; } if test ${ac_cv_lib_c_pthread_mutex_init+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_check_lib_save_LIBS=$LIBS LIBS="-lc $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char pthread_mutex_init (void); int main (void) { return pthread_mutex_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_c_pthread_mutex_init=yes else case e in #( e) ac_cv_lib_c_pthread_mutex_init=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_pthread_mutex_init" >&5 printf "%s\n" "$ac_cv_lib_c_pthread_mutex_init" >&6; } if test "x$ac_cv_lib_c_pthread_mutex_init" = xyes then : tcl_ok=yes else case e in #( e) tcl_ok=no ;; esac fi if test "$tcl_ok" = "no"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc_r" >&5 printf %s "checking for pthread_mutex_init in -lc_r... " >&6; } if test ${ac_cv_lib_c_r_pthread_mutex_init+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_check_lib_save_LIBS=$LIBS LIBS="-lc_r $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char pthread_mutex_init (void); int main (void) { return pthread_mutex_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_c_r_pthread_mutex_init=yes else case e in #( e) ac_cv_lib_c_r_pthread_mutex_init=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5 printf "%s\n" "$ac_cv_lib_c_r_pthread_mutex_init" >&6; } if test "x$ac_cv_lib_c_r_pthread_mutex_init" = xyes then : tcl_ok=yes else case e in #( e) tcl_ok=no ;; esac fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -pthread" else TCL_THREADS=0 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Do not know how to find pthread lib on your system - thread support disabled" >&5 printf "%s\n" "$as_me: WARNING: Do not know how to find pthread lib on your system - thread support disabled" >&2;} fi fi fi fi fi else TCL_THREADS=0 fi # Do checking message here to not mess up interleaved configure output { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for building with threads" >&5 printf %s "checking for building with threads... " >&6; } if test "${TCL_THREADS}" = 1; then printf "%s\n" "#define TCL_THREADS 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes (default)" >&5 printf "%s\n" "yes (default)" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi # TCL_THREADS sanity checking. See if our request for building with # threads is the same as the way Tcl was built. If not, warn the user. case ${TCL_DEFS} in *THREADS=1*) if test "${TCL_THREADS}" = "0"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Building ${PACKAGE_NAME} without threads enabled, but building against Tcl that IS thread-enabled. It is recommended to use --enable-threads." >&5 printf "%s\n" "$as_me: WARNING: Building ${PACKAGE_NAME} without threads enabled, but building against Tcl that IS thread-enabled. It is recommended to use --enable-threads." >&2;} fi ;; esac #-------------------------------------------------------------------- # The statement below defines a collection of symbols related to # building as a shared library instead of a static library. #-------------------------------------------------------------------- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to build libraries" >&5 printf %s "checking how to build libraries... " >&6; } # Check whether --enable-shared was given. if test ${enable_shared+y} then : enableval=$enable_shared; shared_ok=$enableval else case e in #( e) shared_ok=yes ;; esac fi if test "${enable_shared+set}" = set; then enableval="$enable_shared" shared_ok=$enableval else shared_ok=yes fi # Check whether --enable-stubs was given. if test ${enable_stubs+y} then : enableval=$enable_stubs; stubs_ok=$enableval else case e in #( e) stubs_ok=yes ;; esac fi if test "${enable_stubs+set}" = set; then enableval="$enable_stubs" stubs_ok=$enableval else stubs_ok=yes fi # Stubs are always enabled for shared builds if test "$shared_ok" = "yes" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: shared" >&5 printf "%s\n" "shared" >&6; } SHARED_BUILD=1 STUBS_BUILD=1 else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: static" >&5 printf "%s\n" "static" >&6; } SHARED_BUILD=0 printf "%s\n" "#define STATIC_BUILD 1" >>confdefs.h if test "$stubs_ok" = "yes" ; then STUBS_BUILD=1 else STUBS_BUILD=0 fi fi if test "${STUBS_BUILD}" = "1" ; then printf "%s\n" "#define USE_TCL_STUBS 1" >>confdefs.h printf "%s\n" "#define USE_TCLOO_STUBS 1" >>confdefs.h if test "${TEA_WINDOWINGSYSTEM}" != ""; then printf "%s\n" "#define USE_TK_STUBS 1" >>confdefs.h fi fi #-------------------------------------------------------------------- # This macro figures out what flags to use with the compiler/linker # when building shared/static debug/optimized objects. This information # can be taken from the tclConfig.sh file, but this figures it all out. #-------------------------------------------------------------------- if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. set dummy ${ac_tool_prefix}ranlib; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_RANLIB+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi RANLIB=$ac_cv_prog_RANLIB if test -n "$RANLIB"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 printf "%s\n" "$RANLIB" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_RANLIB"; then ac_ct_RANLIB=$RANLIB # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_RANLIB+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_RANLIB"; then ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_RANLIB="ranlib" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB if test -n "$ac_ct_RANLIB"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 printf "%s\n" "$ac_ct_RANLIB" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_RANLIB" = x; then RANLIB=":" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac RANLIB=$ac_ct_RANLIB fi else RANLIB="$ac_cv_prog_RANLIB" fi # Step 0.a: Enable 64 bit support? { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if 64bit support is requested" >&5 printf %s "checking if 64bit support is requested... " >&6; } # Check whether --enable-64bit was given. if test ${enable_64bit+y} then : enableval=$enable_64bit; do64bit=$enableval else case e in #( e) do64bit=no ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5 printf "%s\n" "$do64bit" >&6; } # Step 0.b: Enable Solaris 64 bit VIS support? { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if 64bit Sparc VIS support is requested" >&5 printf %s "checking if 64bit Sparc VIS support is requested... " >&6; } # Check whether --enable-64bit-vis was given. if test ${enable_64bit_vis+y} then : enableval=$enable_64bit_vis; do64bitVIS=$enableval else case e in #( e) do64bitVIS=no ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $do64bitVIS" >&5 printf "%s\n" "$do64bitVIS" >&6; } # Force 64bit on with VIS if test "$do64bitVIS" = "yes" then : do64bit=yes fi # Step 0.c: Check if visibility support is available. Do this here so # that platform specific alternatives can be used below if this fails. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler supports visibility \"hidden\"" >&5 printf %s "checking if compiler supports visibility \"hidden\"... " >&6; } if test ${tcl_cv_cc_visibility_hidden+y} then : printf %s "(cached) " >&6 else case e in #( e) hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ extern __attribute__((__visibility__("hidden"))) void f(void); void f(void) {} int main (void) { f(); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : tcl_cv_cc_visibility_hidden=yes else case e in #( e) tcl_cv_cc_visibility_hidden=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_visibility_hidden" >&5 printf "%s\n" "$tcl_cv_cc_visibility_hidden" >&6; } if test $tcl_cv_cc_visibility_hidden = yes then : printf "%s\n" "#define MODULE_SCOPE extern __attribute__((__visibility__(\"hidden\")))" >>confdefs.h printf "%s\n" "#define HAVE_HIDDEN 1" >>confdefs.h fi # Step 0.d: Disable -rpath support? { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if rpath support is requested" >&5 printf %s "checking if rpath support is requested... " >&6; } # Check whether --enable-rpath was given. if test ${enable_rpath+y} then : enableval=$enable_rpath; doRpath=$enableval else case e in #( e) doRpath=yes ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $doRpath" >&5 printf "%s\n" "$doRpath" >&6; } # Set the variable "system" to hold the name and version number # for the system. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking system version" >&5 printf %s "checking system version... " >&6; } if test ${tcl_cv_sys_version+y} then : printf %s "(cached) " >&6 else case e in #( e) # TEA specific: if test "${TEA_PLATFORM}" = "windows" ; then tcl_cv_sys_version=windows else tcl_cv_sys_version=`uname -s`-`uname -r` if test "$?" -ne 0 ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5 printf "%s\n" "$as_me: WARNING: can't find uname command" >&2;} tcl_cv_sys_version=unknown else if test "`uname -s`" = "AIX" ; then tcl_cv_sys_version=AIX-`uname -v`.`uname -r` fi if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then tcl_cv_sys_version=NetBSD-Debian fi fi fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5 printf "%s\n" "$tcl_cv_sys_version" >&6; } system=$tcl_cv_sys_version # Require ranlib early so we can override it in special cases below. # Set configuration options based on system name and version. # This is similar to Tcl's unix/tcl.m4 except that we've added a # "windows" case and removed some core-only vars. do64bit_ok=no # default to '{$LIBS}' and set to "" on per-platform necessary basis SHLIB_LD_LIBS='${LIBS}' # When ld needs options to work in 64-bit mode, put them in # LDFLAGS_ARCH so they eventually end up in LDFLAGS even if [load] # is disabled by the user. [Bug 1016796] LDFLAGS_ARCH="" UNSHARED_LIB_SUFFIX="" # TEA specific: use PACKAGE_VERSION instead of VERSION TCL_TRIM_DOTS='`echo ${PACKAGE_VERSION} | tr -d .`' ECHO_VERSION='`echo ${PACKAGE_VERSION}`' TCL_LIB_VERSIONS_OK=ok CFLAGS_DEBUG=-g if test "$GCC" = yes then : CFLAGS_OPTIMIZE=-O2 CFLAGS_WARNING="-Wall" else case e in #( e) CFLAGS_OPTIMIZE=-O CFLAGS_WARNING="" ;; esac fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args. set dummy ${ac_tool_prefix}ar; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_AR+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$AR"; then ac_cv_prog_AR="$AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_AR="${ac_tool_prefix}ar" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi AR=$ac_cv_prog_AR if test -n "$AR"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $AR" >&5 printf "%s\n" "$AR" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_AR"; then ac_ct_AR=$AR # Extract the first word of "ar", so it can be a program name with args. set dummy ar; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_AR+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_AR"; then ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_AR="ar" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi ac_ct_AR=$ac_cv_prog_ac_ct_AR if test -n "$ac_ct_AR"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5 printf "%s\n" "$ac_ct_AR" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_AR" = x; then AR="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac AR=$ac_ct_AR fi else AR="$ac_cv_prog_AR" fi STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" if test "x$SHLIB_VERSION" = x then : SHLIB_VERSION="" else case e in #( e) SHLIB_VERSION=".$SHLIB_VERSION" ;; esac fi case $system in # TEA specific: windows) MACHINE="X86" if test "$do64bit" != "no" ; then case "$do64bit" in amd64|x64|yes) MACHINE="AMD64" ; # default to AMD64 64-bit build ;; arm64|aarch64) MACHINE="ARM64" ;; ia64) MACHINE="IA64" ;; esac fi if test "$GCC" != "yes" ; then if test "${SHARED_BUILD}" = "0" ; then runtime=-MT else runtime=-MD fi case "x`echo \${VisualStudioVersion}`" in x1[4-9]*) lflags="${lflags} -nodefaultlib:libucrt.lib" vars="ucrt.lib" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then # Convert foo.lib to -lfoo for GCC. No-op if not *.lib i=`echo "$i" | sed -e 's/^\([^-].*\)\.[lL][iI][bB]$/-l\1/'` fi PKG_LIBS="$PKG_LIBS $i" done ;; *) ;; esac if test "$do64bit" != "no" ; then CC="cl.exe" RC="rc.exe" lflags="${lflags} -nologo -MACHINE:${MACHINE} " LINKBIN="link.exe" CFLAGS_DEBUG="-nologo -Zi -Od -W3 ${runtime}d" CFLAGS_OPTIMIZE="-nologo -O2 -W2 ${runtime}" # Avoid 'unresolved external symbol __security_cookie' # errors, c.f. http://support.microsoft.com/?id=894573 vars="bufferoverflowU.lib" for i in $vars; do if test "${TEA_PLATFORM}" = "windows" -a "$GCC" = "yes" ; then # Convert foo.lib to -lfoo for GCC. No-op if not *.lib i=`echo "$i" | sed -e 's/^\([^-].*\)\.[lL][iI][bB]$/-l\1/'` fi PKG_LIBS="$PKG_LIBS $i" done else RC="rc" lflags="${lflags} -nologo" LINKBIN="link" CFLAGS_DEBUG="-nologo -Z7 -Od -W3 -WX ${runtime}d" CFLAGS_OPTIMIZE="-nologo -O2 -W2 ${runtime}" fi fi if test "$GCC" = "yes"; then # mingw gcc mode if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}windres", so it can be a program name with args. set dummy ${ac_tool_prefix}windres; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_RC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$RC"; then ac_cv_prog_RC="$RC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_RC="${ac_tool_prefix}windres" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi RC=$ac_cv_prog_RC if test -n "$RC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $RC" >&5 printf "%s\n" "$RC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_RC"; then ac_ct_RC=$RC # Extract the first word of "windres", so it can be a program name with args. set dummy windres; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_RC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_RC"; then ac_cv_prog_ac_ct_RC="$ac_ct_RC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_RC="windres" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi ac_ct_RC=$ac_cv_prog_ac_ct_RC if test -n "$ac_ct_RC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RC" >&5 printf "%s\n" "$ac_ct_RC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_RC" = x; then RC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac RC=$ac_ct_RC fi else RC="$ac_cv_prog_RC" fi CFLAGS_DEBUG="-g" CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" SHLIB_LD='${CC} -shared' UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' LDFLAGS_CONSOLE="-wl,--subsystem,console ${lflags}" LDFLAGS_WINDOW="-wl,--subsystem,windows ${lflags}" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for cross-compile version of gcc" >&5 printf %s "checking for cross-compile version of gcc... " >&6; } if test ${ac_cv_cross+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef _WIN32 #error cross-compiler #endif int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_cross=yes else case e in #( e) ac_cv_cross=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cross" >&5 printf "%s\n" "$ac_cv_cross" >&6; } if test "$ac_cv_cross" = "yes"; then case "$do64bit" in amd64|x64|yes) CC="x86_64-w64-mingw32-${CC}" LD="x86_64-w64-mingw32-ld" AR="x86_64-w64-mingw32-ar" RANLIB="x86_64-w64-mingw32-ranlib" RC="x86_64-w64-mingw32-windres" ;; arm64|aarch64) CC="aarch64-w64-mingw32-clang" LD="aarch64-w64-mingw32-ld" AR="aarch64-w64-mingw32-ar" RANLIB="aarch64-w64-mingw32-ranlib" RC="aarch64-w64-mingw32-windres" ;; *) CC="i686-w64-mingw32-${CC}" LD="i686-w64-mingw32-ld" AR="i686-w64-mingw32-ar" RANLIB="i686-w64-mingw32-ranlib" RC="i686-w64-mingw32-windres" ;; esac fi else SHLIB_LD="${LINKBIN} -dll ${lflags}" # link -lib only works when -lib is the first arg STLIB_LD="${LINKBIN} -lib ${lflags}" UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.lib' PATHTYPE=-w # For information on what debugtype is most useful, see: # http://msdn.microsoft.com/library/en-us/dnvc60/html/gendepdebug.asp # and also # http://msdn2.microsoft.com/en-us/library/y0zzbyt4%28VS.80%29.aspx # This essentially turns it all on. LDFLAGS_DEBUG="-debug -debugtype:cv" LDFLAGS_OPTIMIZE="-release" LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" fi SHLIB_SUFFIX=".dll" SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.dll' TCL_LIB_VERSIONS_OK=nodots ;; AIX-*) if test "$GCC" != "yes" then : # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r|*_r\ *) # ok ... ;; *) # Make sure only first arg gets _r CC=`echo "$CC" | sed -e 's/^\([^ ]*\)/\1_r/'` ;; esac { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using $CC for compiling with threads" >&5 printf "%s\n" "Using $CC for compiling with threads" >&6; } fi LIBS="$LIBS -lc" SHLIB_CFLAGS="" SHLIB_SUFFIX=".so" LD_LIBRARY_PATH_VAR="LIBPATH" # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = yes then : if test "$GCC" = yes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5 printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} else case e in #( e) do64bit_ok=yes CFLAGS="$CFLAGS -q64" LDFLAGS_ARCH="-q64" RANLIB="${RANLIB} -X64" AR="${AR} -X64" SHLIB_LD_FLAGS="-b64" ;; esac fi fi if test "`uname -m`" = ia64 then : # AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC SHLIB_LD="/usr/ccs/bin/ld -G -z text" if test "$GCC" = yes then : CC_SEARCH_FLAGS='"-Wl,-R,${LIB_RUNTIME_DIR}"' else case e in #( e) CC_SEARCH_FLAGS='"-R${LIB_RUNTIME_DIR}"' ;; esac fi LD_SEARCH_FLAGS='-R "${LIB_RUNTIME_DIR}"' else case e in #( e) if test "$GCC" = yes then : SHLIB_LD='${CC} -shared -Wl,-bexpall' else case e in #( e) SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bexpall -H512 -T512 -bnoentry" LDFLAGS="$LDFLAGS -brtl" ;; esac fi SHLIB_LD="${SHLIB_LD} ${SHLIB_LD_FLAGS}" CC_SEARCH_FLAGS='"-L${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; esac fi ;; BeOS*) SHLIB_CFLAGS="-fPIC" SHLIB_LD='${CC} -nostart' SHLIB_SUFFIX=".so" #----------------------------------------------------------- # Check for inet_ntoa in -lbind, for BeOS (which also needs # -lsocket, even if the network functions are in -lnet which # is always linked to, for compatibility. #----------------------------------------------------------- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lbind" >&5 printf %s "checking for inet_ntoa in -lbind... " >&6; } if test ${ac_cv_lib_bind_inet_ntoa+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_check_lib_save_LIBS=$LIBS LIBS="-lbind $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char inet_ntoa (void); int main (void) { return inet_ntoa (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_bind_inet_ntoa=yes else case e in #( e) ac_cv_lib_bind_inet_ntoa=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bind_inet_ntoa" >&5 printf "%s\n" "$ac_cv_lib_bind_inet_ntoa" >&6; } if test "x$ac_cv_lib_bind_inet_ntoa" = xyes then : LIBS="$LIBS -lbind -lsocket" fi ;; BSD/OS-2.1*|BSD/OS-3*) SHLIB_CFLAGS="" SHLIB_LD="shlicc -r" SHLIB_SUFFIX=".so" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; BSD/OS-4.*) SHLIB_CFLAGS="-export-dynamic -fPIC" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".so" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; CYGWIN_*) SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a" EXEEXT=".exe" do64bit_ok=yes CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; dgux*) SHLIB_CFLAGS="-K PIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lnetwork" >&5 printf %s "checking for inet_ntoa in -lnetwork... " >&6; } if test ${ac_cv_lib_network_inet_ntoa+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_check_lib_save_LIBS=$LIBS LIBS="-lnetwork $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char inet_ntoa (void); int main (void) { return inet_ntoa (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_network_inet_ntoa=yes else case e in #( e) ac_cv_lib_network_inet_ntoa=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_network_inet_ntoa" >&5 printf "%s\n" "$ac_cv_lib_network_inet_ntoa" >&6; } if test "x$ac_cv_lib_network_inet_ntoa" = xyes then : LIBS="$LIBS -lnetwork" fi ;; HP-UX-*.11.*) # Use updated header definitions where possible printf "%s\n" "#define _XOPEN_SOURCE_EXTENDED 1" >>confdefs.h # TEA specific: Needed by Tcl, but not most extensions #AC_DEFINE(_XOPEN_SOURCE, 1, [Do we want to use the XOPEN network library?]) #LIBS="$LIBS -lxnet" # Use the XOPEN network library if test "`uname -m`" = ia64 then : SHLIB_SUFFIX=".so" else case e in #( e) SHLIB_SUFFIX=".sl" ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5 printf %s "checking for shl_load in -ldld... " >&6; } if test ${ac_cv_lib_dld_shl_load+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char shl_load (void); int main (void) { return shl_load (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dld_shl_load=yes else case e in #( e) ac_cv_lib_dld_shl_load=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5 printf "%s\n" "$ac_cv_lib_dld_shl_load" >&6; } if test "x$ac_cv_lib_dld_shl_load" = xyes then : tcl_ok=yes else case e in #( e) tcl_ok=no ;; esac fi if test "$tcl_ok" = yes then : SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='"-Wl,+s,+b,${LIB_RUNTIME_DIR}:."' LD_SEARCH_FLAGS='+s +b "${LIB_RUNTIME_DIR}:."' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi if test "$GCC" = yes then : SHLIB_LD='${CC} -shared' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} else case e in #( e) CFLAGS="$CFLAGS -z" ;; esac fi # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes" then : if test "$GCC" = yes then : case `${CC} -dumpmachine` in hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD='${CC} -shared' if test $doRpath = yes then : CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5 printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} ;; esac else case e in #( e) do64bit_ok=yes CFLAGS="$CFLAGS +DD64" LDFLAGS_ARCH="+DD64" ;; esac fi fi ;; HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) SHLIB_SUFFIX=".sl" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5 printf %s "checking for shl_load in -ldld... " >&6; } if test ${ac_cv_lib_dld_shl_load+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char shl_load (void); int main (void) { return shl_load (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dld_shl_load=yes else case e in #( e) ac_cv_lib_dld_shl_load=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5 printf "%s\n" "$ac_cv_lib_dld_shl_load" >&6; } if test "x$ac_cv_lib_dld_shl_load" = xyes then : tcl_ok=yes else case e in #( e) tcl_ok=no ;; esac fi if test "$tcl_ok" = yes then : SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS="" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='"-Wl,+s,+b,${LIB_RUNTIME_DIR}:."' LD_SEARCH_FLAGS='+s +b "${LIB_RUNTIME_DIR}:."' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi ;; IRIX-5.*) SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_SUFFIX=".so" case " $LIBOBJS " in *" mkstemp.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;; esac if test $doRpath = yes then : CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath "${LIB_RUNTIME_DIR}"' fi ;; IRIX-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_SUFFIX=".so" if test $doRpath = yes then : CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath "${LIB_RUNTIME_DIR}"' fi if test "$GCC" = yes then : CFLAGS="$CFLAGS -mabi=n32" LDFLAGS="$LDFLAGS -mabi=n32" else case e in #( e) case $system in IRIX-6.3) # Use to build 6.2 compatible binaries on 6.3. CFLAGS="$CFLAGS -n32 -D_OLD_TERMIOS" ;; *) CFLAGS="$CFLAGS -n32" ;; esac LDFLAGS="$LDFLAGS -n32" ;; esac fi ;; IRIX64-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_SUFFIX=".so" if test $doRpath = yes then : CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath "${LIB_RUNTIME_DIR}"' fi # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = yes then : if test "$GCC" = yes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported by gcc" >&5 printf "%s\n" "$as_me: WARNING: 64bit mode not supported by gcc" >&2;} else case e in #( e) do64bit_ok=yes SHLIB_LD="ld -64 -shared -rdata_shared" CFLAGS="$CFLAGS -64" LDFLAGS_ARCH="-64" ;; esac fi fi ;; Linux*|GNU*|NetBSD-Debian|DragonFly-*|FreeBSD-*) SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" # TEA specific: CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" # TEA specific: use LDFLAGS_DEFAULT instead of LDFLAGS SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS_DEFAULT} -shared' LDFLAGS="$LDFLAGS -Wl,--export-dynamic" case $system in DragonFly-*|FreeBSD-*) if test "${TCL_THREADS}" = "1" then : # The -pthread needs to go in the LDFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS $PTHREAD_CFLAGS" LDFLAGS="$LDFLAGS $PTHREAD_LIBS" fi ;; esac if test $doRpath = yes then : CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} if test "`uname -m`" = "alpha" then : CFLAGS="$CFLAGS -mieee" fi if test $do64bit = yes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -m64 flag" >&5 printf %s "checking if compiler accepts -m64 flag... " >&6; } if test ${tcl_cv_cc_m64+y} then : printf %s "(cached) " >&6 else case e in #( e) hold_cflags=$CFLAGS CFLAGS="$CFLAGS -m64" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : tcl_cv_cc_m64=yes else case e in #( e) tcl_cv_cc_m64=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_m64" >&5 printf "%s\n" "$tcl_cv_cc_m64" >&6; } if test $tcl_cv_cc_m64 = yes then : CFLAGS="$CFLAGS -m64" do64bit_ok=yes fi fi # The combo of gcc + glibc has a bug related to inlining of # functions like strtod(). The -fno-builtin flag should address # this problem but it does not work. The -fno-inline flag is kind # of overkill but it works. Disable inlining only when one of the # files in compat/*.c is being linked in. if test x"${USE_COMPAT}" != x then : CFLAGS="$CFLAGS -fno-inline" fi ;; Lynx*) SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" CFLAGS_OPTIMIZE=-02 SHLIB_LD='${CC} -shared' LD_FLAGS="-Wl,--export-dynamic" if test $doRpath = yes then : CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' fi ;; OpenBSD-*) arch=`arch -s` case "$arch" in alpha|sparc64) SHLIB_CFLAGS="-fPIC" ;; *) SHLIB_CFLAGS="-fpic" ;; esac SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" if test $doRpath = yes then : CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so${SHLIB_VERSION}' LDFLAGS="$LDFLAGS -Wl,-export-dynamic" CFLAGS_OPTIMIZE="-O2" # On OpenBSD: Compile with -pthread # Don't link with -lpthread LIBS=`echo $LIBS | sed s/-lpthread//` CFLAGS="$CFLAGS -pthread" # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" LDFLAGS="$LDFLAGS -export-dynamic" if test $doRpath = yes then : CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} # The -pthread needs to go in the CFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" ;; Darwin-*) CFLAGS_OPTIMIZE="-Os" SHLIB_CFLAGS="-fno-common" # To avoid discrepancies between what headers configure sees during # preprocessing tests and compiling tests, move any -isysroot and # -mmacosx-version-min flags from CFLAGS to CPPFLAGS: CPPFLAGS="${CPPFLAGS} `echo " ${CFLAGS}" | \ awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ if ($i~/^(isysroot|mmacosx-version-min)/) print "-"$i}'`" CFLAGS="`echo " ${CFLAGS}" | \ awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ if (!($i~/^(isysroot|mmacosx-version-min)/)) print "-"$i}'`" if test $do64bit = yes then : case `arch` in ppc) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch ppc64 flag" >&5 printf %s "checking if compiler accepts -arch ppc64 flag... " >&6; } if test ${tcl_cv_cc_arch_ppc64+y} then : printf %s "(cached) " >&6 else case e in #( e) hold_cflags=$CFLAGS CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : tcl_cv_cc_arch_ppc64=yes else case e in #( e) tcl_cv_cc_arch_ppc64=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_ppc64" >&5 printf "%s\n" "$tcl_cv_cc_arch_ppc64" >&6; } if test $tcl_cv_cc_arch_ppc64 = yes then : CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" do64bit_ok=yes fi;; i386) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch x86_64 flag" >&5 printf %s "checking if compiler accepts -arch x86_64 flag... " >&6; } if test ${tcl_cv_cc_arch_x86_64+y} then : printf %s "(cached) " >&6 else case e in #( e) hold_cflags=$CFLAGS CFLAGS="$CFLAGS -arch x86_64" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : tcl_cv_cc_arch_x86_64=yes else case e in #( e) tcl_cv_cc_arch_x86_64=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_x86_64" >&5 printf "%s\n" "$tcl_cv_cc_arch_x86_64" >&6; } if test $tcl_cv_cc_arch_x86_64 = yes then : CFLAGS="$CFLAGS -arch x86_64" do64bit_ok=yes fi;; *) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&5 printf "%s\n" "$as_me: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&2;};; esac else case e in #( e) # Check for combined 32-bit and 64-bit fat build if echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64) ' \ && echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) ' then : fat_32_64=yes fi ;; esac fi # TEA specific: use LDFLAGS_DEFAULT instead of LDFLAGS SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS_DEFAULT}' # TEA specific: link shlib with current and compatibility version flags vers=`echo ${PACKAGE_VERSION} | sed -e 's/^\([0-9]\{1,5\}\)\(\(\.[0-9]\{1,3\}\)\{0,2\}\).*$/\1\2/p' -e d` SHLIB_LD="${SHLIB_LD} -current_version ${vers:-0} -compatibility_version ${vers:-0}" SHLIB_SUFFIX=".dylib" LDFLAGS="$LDFLAGS -headerpad_max_install_names" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ld accepts -search_paths_first flag" >&5 printf %s "checking if ld accepts -search_paths_first flag... " >&6; } if test ${tcl_cv_ld_search_paths_first+y} then : printf %s "(cached) " >&6 else case e in #( e) hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-search_paths_first" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { int i; ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : tcl_cv_ld_search_paths_first=yes else case e in #( e) tcl_cv_ld_search_paths_first=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_search_paths_first" >&5 printf "%s\n" "$tcl_cv_ld_search_paths_first" >&6; } if test $tcl_cv_ld_search_paths_first = yes then : LDFLAGS="$LDFLAGS -Wl,-search_paths_first" fi if test "$tcl_cv_cc_visibility_hidden" != yes then : printf "%s\n" "#define MODULE_SCOPE __private_extern__" >>confdefs.h tcl_cv_cc_visibility_hidden=yes fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" # TEA specific: for combined 32 & 64 bit fat builds of Tk # extensions, verify that 64-bit build is possible. if test "$fat_32_64" = yes && test -n "${TK_BIN_DIR}" then : if test "${TEA_WINDOWINGSYSTEM}" = x11 then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for 64-bit X11" >&5 printf %s "checking for 64-bit X11... " >&6; } if test ${tcl_cv_lib_x11_64+y} then : printf %s "(cached) " >&6 else case e in #( e) for v in CFLAGS CPPFLAGS LDFLAGS; do eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"' done CPPFLAGS="$CPPFLAGS -I/usr/X11R6/include" LDFLAGS="$LDFLAGS -L/usr/X11R6/lib -lX11" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { XrmInitialize(); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : tcl_cv_lib_x11_64=yes else case e in #( e) tcl_cv_lib_x11_64=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_lib_x11_64" >&5 printf "%s\n" "$tcl_cv_lib_x11_64" >&6; } fi if test "${TEA_WINDOWINGSYSTEM}" = aqua then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for 64-bit Tk" >&5 printf %s "checking for 64-bit Tk... " >&6; } if test ${tcl_cv_lib_tk_64+y} then : printf %s "(cached) " >&6 else case e in #( e) for v in CFLAGS CPPFLAGS LDFLAGS; do eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"' done CPPFLAGS="$CPPFLAGS -DUSE_TCL_STUBS=1 -DUSE_TK_STUBS=1 ${TCL_INCLUDES} ${TK_INCLUDES}" LDFLAGS="$LDFLAGS ${TCL_STUB_LIB_SPEC} ${TK_STUB_LIB_SPEC}" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { Tk_InitStubs(NULL, "", 0); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : tcl_cv_lib_tk_64=yes else case e in #( e) tcl_cv_lib_tk_64=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_lib_tk_64" >&5 printf "%s\n" "$tcl_cv_lib_tk_64" >&6; } fi # remove 64-bit arch flags from CFLAGS et al. if configuration # does not support 64-bit. if test "$tcl_cv_lib_tk_64" = no -o "$tcl_cv_lib_x11_64" = no then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Removing 64-bit architectures from compiler & linker flags" >&5 printf "%s\n" "$as_me: Removing 64-bit architectures from compiler & linker flags" >&6;} for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"' done fi fi ;; OS/390-*) CFLAGS_OPTIMIZE="" # Optimizer is buggy printf "%s\n" "#define _OE_SOCKETS 1" >>confdefs.h ;; OSF1-V*) # Digital OSF/1 SHLIB_CFLAGS="" if test "$SHARED_BUILD" = 1 then : SHLIB_LD='ld -shared -expect_unresolved "*"' else case e in #( e) SHLIB_LD='ld -non_shared -expect_unresolved "*"' ;; esac fi SHLIB_SUFFIX=".so" if test $doRpath = yes then : CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' fi if test "$GCC" = yes then : CFLAGS="$CFLAGS -mieee" else case e in #( e) CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee" ;; esac fi # see pthread_intro(3) for pthread support on osf1, k.furukawa CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" LIBS=`echo $LIBS | sed s/-lpthreads//` if test "$GCC" = yes then : LIBS="$LIBS -lpthread -lmach -lexc" else case e in #( e) CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" ;; esac fi ;; QNX-6*) # QNX RTP # This may work for all QNX, but it was only reported for v6. SHLIB_CFLAGS="-fPIC" SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SCO_SV-3.2*) if test "$GCC" = yes then : SHLIB_CFLAGS="-fPIC -melf" LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" else case e in #( e) SHLIB_CFLAGS="-Kpic -belf" LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" ;; esac fi SHLIB_LD="ld -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SunOS-5.[0-6]) # Careful to not let 5.10+ fall into this case # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. printf "%s\n" "#define _REENTRANT 1" >>confdefs.h printf "%s\n" "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h SHLIB_CFLAGS="-KPIC" SHLIB_SUFFIX=".so" if test "$GCC" = yes then : SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='"-Wl,-R,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} else case e in #( e) SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-R "${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; esac fi ;; SunOS-5*) # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. printf "%s\n" "#define _REENTRANT 1" >>confdefs.h printf "%s\n" "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h SHLIB_CFLAGS="-KPIC" # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = yes then : arch=`isainfo` if test "$arch" = "sparcv9 sparc" then : if test "$GCC" = yes then : if test "`${CC} -dumpversion | awk -F. '{print $1}'`" -lt 3 then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5 printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;} else case e in #( e) do64bit_ok=yes CFLAGS="$CFLAGS -m64 -mcpu=v9" LDFLAGS="$LDFLAGS -m64 -mcpu=v9" SHLIB_CFLAGS="-fPIC" ;; esac fi else case e in #( e) do64bit_ok=yes if test "$do64bitVIS" = yes then : CFLAGS="$CFLAGS -xarch=v9a" LDFLAGS_ARCH="-xarch=v9a" else case e in #( e) CFLAGS="$CFLAGS -xarch=v9" LDFLAGS_ARCH="-xarch=v9" ;; esac fi # Solaris 64 uses this as well #LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64" ;; esac fi else case e in #( e) if test "$arch" = "amd64 i386" then : if test "$GCC" = yes then : case $system in SunOS-5.1[1-9]*|SunOS-5.[2-9][0-9]*) do64bit_ok=yes CFLAGS="$CFLAGS -m64" LDFLAGS="$LDFLAGS -m64";; *) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5 printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;};; esac else case e in #( e) do64bit_ok=yes case $system in SunOS-5.1[1-9]*|SunOS-5.[2-9][0-9]*) CFLAGS="$CFLAGS -m64" LDFLAGS="$LDFLAGS -m64";; *) CFLAGS="$CFLAGS -xarch=amd64" LDFLAGS="$LDFLAGS -xarch=amd64";; esac ;; esac fi else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported for $arch" >&5 printf "%s\n" "$as_me: WARNING: 64bit mode not supported for $arch" >&2;} ;; esac fi ;; esac fi fi SHLIB_SUFFIX=".so" if test "$GCC" = yes then : SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='"-Wl,-R,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} if test "$do64bit_ok" = yes then : if test "$arch" = "sparcv9 sparc" then : # We need to specify -static-libgcc or we need to # add the path to the sparv9 libgcc. # JH: static-libgcc is necessary for core Tcl, but may # not be necessary for extensions. SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" # for finding sparcv9 libgcc, get the regular libgcc # path, remove so name and append 'sparcv9' #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" else case e in #( e) if test "$arch" = "amd64 i386" then : # JH: static-libgcc is necessary for core Tcl, but may # not be necessary for extensions. SHLIB_LD="$SHLIB_LD -m64 -static-libgcc" fi ;; esac fi fi else case e in #( e) case $system in SunOS-5.[1-9][0-9]*) # TEA specific: use LDFLAGS_DEFAULT instead of LDFLAGS SHLIB_LD='${CC} -G -z text ${LDFLAGS_DEFAULT}';; *) SHLIB_LD='/usr/ccs/bin/ld -G -z text';; esac CC_SEARCH_FLAGS='"-Wl,-R,${LIB_RUNTIME_DIR}"' LD_SEARCH_FLAGS='-R "${LIB_RUNTIME_DIR}"' ;; esac fi ;; UNIX_SV* | UnixWare-5*) SHLIB_CFLAGS="-KPIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers # that don't grok the -Bexport option. Test that it does. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ld accepts -Bexport flag" >&5 printf %s "checking for ld accepts -Bexport flag... " >&6; } if test ${tcl_cv_ld_Bexport+y} then : printf %s "(cached) " >&6 else case e in #( e) hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-Bexport" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { int i; ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : tcl_cv_ld_Bexport=yes else case e in #( e) tcl_cv_ld_Bexport=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_Bexport" >&5 printf "%s\n" "$tcl_cv_ld_Bexport" >&6; } if test $tcl_cv_ld_Bexport = yes then : LDFLAGS="$LDFLAGS -Wl,-Bexport" fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; esac if test "$do64bit" = yes -a "$do64bit_ok" = no then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5 printf "%s\n" "$as_me: WARNING: 64bit support being disabled -- don't know magic for this platform" >&2;} fi # Add in the arch flags late to ensure it wasn't removed. # Not necessary in TEA, but this is aligned with core LDFLAGS="$LDFLAGS $LDFLAGS_ARCH" # If we're running gcc, then change the C flags for compiling shared # libraries to the right flags for gcc, instead of those for the # standard manufacturer compiler. if test "$GCC" = yes then : case $system in AIX-*) ;; BSD/OS*) ;; CYGWIN_*|MINGW32_*|MINGW64_*|MSYS_*) ;; IRIX*) ;; NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;; Darwin-*) ;; SCO_SV-3.2*) ;; windows) ;; *) SHLIB_CFLAGS="-fPIC" ;; esac fi if test "$tcl_cv_cc_visibility_hidden" != yes then : printf "%s\n" "#define MODULE_SCOPE extern" >>confdefs.h fi if test "$SHARED_LIB_SUFFIX" = "" then : # TEA specific: use PACKAGE_VERSION instead of VERSION SHARED_LIB_SUFFIX='${PACKAGE_VERSION}${SHLIB_SUFFIX}' fi if test "$UNSHARED_LIB_SUFFIX" = "" then : # TEA specific: use PACKAGE_VERSION instead of VERSION UNSHARED_LIB_SUFFIX='${PACKAGE_VERSION}.a' fi if test "${GCC}" = "yes" -a ${SHLIB_SUFFIX} = ".dll"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for SEH support in compiler" >&5 printf %s "checking for SEH support in compiler... " >&6; } if test ${tcl_cv_seh+y} then : printf %s "(cached) " >&6 else case e in #( e) if test "$cross_compiling" = yes then : tcl_cv_seh=no else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN int main(int argc, char** argv) { int a, b = 0; __try { a = 666 / b; } __except (EXCEPTION_EXECUTE_HANDLER) { return 0; } return 1; } _ACEOF if ac_fn_c_try_run "$LINENO" then : tcl_cv_seh=yes else case e in #( e) tcl_cv_seh=no ;; esac fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_seh" >&5 printf "%s\n" "$tcl_cv_seh" >&6; } if test "$tcl_cv_seh" = "no" ; then printf "%s\n" "#define HAVE_NO_SEH 1" >>confdefs.h fi # # Check to see if the excpt.h include file provided contains the # definition for EXCEPTION_DISPOSITION; if not, which is the case # with Cygwin's version as of 2002-04-10, define it to be int, # sufficient for getting the current code to work. # { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for EXCEPTION_DISPOSITION support in include files" >&5 printf %s "checking for EXCEPTION_DISPOSITION support in include files... " >&6; } if test ${tcl_cv_eh_disposition+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ # define WIN32_LEAN_AND_MEAN # include # undef WIN32_LEAN_AND_MEAN int main (void) { EXCEPTION_DISPOSITION x; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_eh_disposition=yes else case e in #( e) tcl_cv_eh_disposition=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_eh_disposition" >&5 printf "%s\n" "$tcl_cv_eh_disposition" >&6; } if test "$tcl_cv_eh_disposition" = "no" ; then printf "%s\n" "#define EXCEPTION_DISPOSITION int" >>confdefs.h fi # Check to see if winnt.h defines CHAR, SHORT, and LONG # even if VOID has already been #defined. The win32api # used by mingw and cygwin is known to do this. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for winnt.h that ignores VOID define" >&5 printf %s "checking for winnt.h that ignores VOID define... " >&6; } if test ${tcl_cv_winnt_ignore_void+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define VOID void #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN int main (void) { CHAR c; SHORT s; LONG l; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_winnt_ignore_void=yes else case e in #( e) tcl_cv_winnt_ignore_void=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_winnt_ignore_void" >&5 printf "%s\n" "$tcl_cv_winnt_ignore_void" >&6; } if test "$tcl_cv_winnt_ignore_void" = "yes" ; then printf "%s\n" "#define HAVE_WINNT_IGNORE_VOID 1" >>confdefs.h fi fi # See if the compiler supports casting to a union type. # This is used to stop gcc from printing a compiler # warning when initializing a union member. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for cast to union support" >&5 printf %s "checking for cast to union support... " >&6; } if test ${tcl_cv_cast_to_union+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { union foo { int i; double d; }; union foo f = (union foo) (int) 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_cast_to_union=yes else case e in #( e) tcl_cv_cast_to_union=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cast_to_union" >&5 printf "%s\n" "$tcl_cv_cast_to_union" >&6; } if test "$tcl_cv_cast_to_union" = "yes"; then printf "%s\n" "#define HAVE_CAST_TO_UNION 1" >>confdefs.h fi ac_fn_c_check_header_compile "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default" if test "x$ac_cv_header_stdbool_h" = xyes then : printf "%s\n" "#define HAVE_STDBOOL_H 1" >>confdefs.h fi # These must be called after we do the basic CFLAGS checks and # verify any possible 64-bit or similar switches are necessary { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for required early compiler flags" >&5 printf %s "checking for required early compiler flags... " >&6; } tcl_flags="" if test ${tcl_cv_flag__isoc99_source+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { char *p = (char *)strtoll; char *q = (char *)strtoull; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_flag__isoc99_source=no else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define _ISOC99_SOURCE 1 #include int main (void) { char *p = (char *)strtoll; char *q = (char *)strtoull; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_flag__isoc99_source=yes else case e in #( e) tcl_cv_flag__isoc99_source=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi if test "x${tcl_cv_flag__isoc99_source}" = "xyes" ; then printf "%s\n" "#define _ISOC99_SOURCE 1" >>confdefs.h tcl_flags="$tcl_flags _ISOC99_SOURCE" fi if test "${TCL_MAJOR_VERSION}" -ne 8 ; then if test ${tcl_cv_flag__file_offset_bits+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { switch (0) { case 0: case (sizeof(off_t)==sizeof(long long)): ; } ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_flag__file_offset_bits=no else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define _FILE_OFFSET_BITS 64 #include int main (void) { switch (0) { case 0: case (sizeof(off_t)==sizeof(long long)): ; } ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_flag__file_offset_bits=yes else case e in #( e) tcl_cv_flag__file_offset_bits=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi if test "x${tcl_cv_flag__file_offset_bits}" = "xyes" ; then printf "%s\n" "#define _FILE_OFFSET_BITS 64" >>confdefs.h tcl_flags="$tcl_flags _FILE_OFFSET_BITS" fi fi if test "x${tcl_flags}" = "x" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none" >&5 printf "%s\n" "none" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${tcl_flags}" >&5 printf "%s\n" "${tcl_flags}" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for 64-bit integer type" >&5 printf %s "checking for 64-bit integer type... " >&6; } if test ${tcl_cv_type_64bit+y} then : printf %s "(cached) " >&6 else case e in #( e) tcl_cv_type_64bit=none # See if the compiler knows natively about __int64 cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { __int64 value = (__int64) 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_type_64bit=__int64 else case e in #( e) tcl_type_64bit="long long" ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext # See if we could use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { switch (0) { case 1: case (sizeof(${tcl_type_64bit})==sizeof(long)): ; } ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_type_64bit=${tcl_type_64bit} fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi if test "${tcl_cv_type_64bit}" = none ; then printf "%s\n" "#define TCL_WIDE_INT_IS_LONG 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } elif test "${tcl_cv_type_64bit}" = "__int64" \ -a "${TEA_PLATFORM}" = "windows" ; then # TEA specific: We actually want to use the default tcl.h checks in # this case to handle both TCL_WIDE_INT_TYPE and TCL_LL_MODIFIER* { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: using Tcl header defaults" >&5 printf "%s\n" "using Tcl header defaults" >&6; } else printf "%s\n" "#define TCL_WIDE_INT_TYPE ${tcl_cv_type_64bit}" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${tcl_cv_type_64bit}" >&5 printf "%s\n" "${tcl_cv_type_64bit}" >&6; } # Now check for auxiliary declarations if test "${TCL_MAJOR_VERSION}" -ne 8 ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for 64-bit time_t" >&5 printf %s "checking for 64-bit time_t... " >&6; } if test ${tcl_cv_time_t_64+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { switch (0) {case 0: case (sizeof(time_t)==sizeof(long long)): ;} ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_time_t_64=yes else case e in #( e) tcl_cv_time_t_64=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_time_t_64" >&5 printf "%s\n" "$tcl_cv_time_t_64" >&6; } if test "x${tcl_cv_time_t_64}" = "xno" ; then # Note that _TIME_BITS=64 requires _FILE_OFFSET_BITS=64 # which SC_TCL_EARLY_FLAGS has defined if necessary. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if _TIME_BITS=64 enables 64-bit time_t" >&5 printf %s "checking if _TIME_BITS=64 enables 64-bit time_t... " >&6; } if test ${tcl_cv__time_bits+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define _TIME_BITS 64 #include int main (void) { switch (0) {case 0: case (sizeof(time_t)==sizeof(long long)): ;} ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv__time_bits=yes else case e in #( e) tcl_cv__time_bits=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv__time_bits" >&5 printf "%s\n" "$tcl_cv__time_bits" >&6; } if test "x${tcl_cv__time_bits}" = "xyes" ; then printf "%s\n" "#define _TIME_BITS 64" >>confdefs.h fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for struct dirent64" >&5 printf %s "checking for struct dirent64... " >&6; } if test ${tcl_cv_struct_dirent64+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { struct dirent64 p; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_struct_dirent64=yes else case e in #( e) tcl_cv_struct_dirent64=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_dirent64" >&5 printf "%s\n" "$tcl_cv_struct_dirent64" >&6; } if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then printf "%s\n" "#define HAVE_STRUCT_DIRENT64 1" >>confdefs.h fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for DIR64" >&5 printf %s "checking for DIR64... " >&6; } if test ${tcl_cv_DIR64+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { struct dirent64 *p; DIR64 d = opendir64("."); p = readdir64(d); rewinddir64(d); closedir64(d); ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_DIR64=yes else case e in #( e) tcl_cv_DIR64=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_DIR64" >&5 printf "%s\n" "$tcl_cv_DIR64" >&6; } if test "x${tcl_cv_DIR64}" = "xyes" ; then printf "%s\n" "#define HAVE_DIR64 1" >>confdefs.h fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for struct stat64" >&5 printf %s "checking for struct stat64... " >&6; } if test ${tcl_cv_struct_stat64+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { struct stat64 p; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_struct_stat64=yes else case e in #( e) tcl_cv_struct_stat64=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_stat64" >&5 printf "%s\n" "$tcl_cv_struct_stat64" >&6; } if test "x${tcl_cv_struct_stat64}" = "xyes" ; then printf "%s\n" "#define HAVE_STRUCT_STAT64 1" >>confdefs.h fi ac_fn_c_check_func "$LINENO" "open64" "ac_cv_func_open64" if test "x$ac_cv_func_open64" = xyes then : printf "%s\n" "#define HAVE_OPEN64 1" >>confdefs.h fi ac_fn_c_check_func "$LINENO" "lseek64" "ac_cv_func_lseek64" if test "x$ac_cv_func_lseek64" = xyes then : printf "%s\n" "#define HAVE_LSEEK64 1" >>confdefs.h fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for off64_t" >&5 printf %s "checking for off64_t... " >&6; } if test ${tcl_cv_type_off64_t+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { off64_t offset; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : tcl_cv_type_off64_t=yes else case e in #( e) tcl_cv_type_off64_t=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi if test "x${tcl_cv_type_off64_t}" = "xyes" && \ test "x${ac_cv_func_lseek64}" = "xyes" && \ test "x${ac_cv_func_open64}" = "xyes" ; then printf "%s\n" "#define HAVE_TYPE_OFF64_T 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi #-------------------------------------------------------------------- # Set the default compiler switches based on the --enable-symbols option. #-------------------------------------------------------------------- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for build with symbols" >&5 printf %s "checking for build with symbols... " >&6; } # Check whether --enable-symbols was given. if test ${enable_symbols+y} then : enableval=$enable_symbols; tcl_ok=$enableval else case e in #( e) tcl_ok=no ;; esac fi if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT="${CFLAGS_OPTIMIZE} -DNDEBUG" LDFLAGS_DEFAULT="${LDFLAGS_OPTIMIZE}" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } printf "%s\n" "#define TCL_CFG_OPTIMIZED 1" >>confdefs.h else CFLAGS_DEFAULT="${CFLAGS_DEBUG}" LDFLAGS_DEFAULT="${LDFLAGS_DEBUG}" if test "$tcl_ok" = "yes"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes (standard debugging)" >&5 printf "%s\n" "yes (standard debugging)" >&6; } fi fi if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then printf "%s\n" "#define TCL_MEM_DEBUG 1" >>confdefs.h fi if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then if test "$tcl_ok" = "all"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: enabled symbols mem debugging" >&5 printf "%s\n" "enabled symbols mem debugging" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: enabled $tcl_ok debugging" >&5 printf "%s\n" "enabled $tcl_ok debugging" >&6; } fi fi #-------------------------------------------------------------------- # Everyone should be linking against the Tcl stub library. If you # can't for some reason, remove this definition. If you aren't using # stubs, you also need to modify the SHLIB_LD_LIBS setting below to # link against the non-stubbed Tcl library. Add Tk too if necessary. #-------------------------------------------------------------------- printf "%s\n" "#define USE_TCL_STUBS 1" >>confdefs.h #-------------------------------------------------------------------- # This macro generates a line to use when building a library. It # depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS, # and TEA_LOAD_TCLCONFIG macros above. #-------------------------------------------------------------------- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for egrep -e" >&5 printf %s "checking for egrep -e... " >&6; } if test ${ac_cv_path_EGREP_TRADITIONAL+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -z "$EGREP_TRADITIONAL"; then ac_path_EGREP_TRADITIONAL_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_prog in grep ggrep do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP_TRADITIONAL="$as_dir$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_EGREP_TRADITIONAL" || continue # Check for GNU ac_path_EGREP_TRADITIONAL and select it if it is found. # Check for GNU $ac_path_EGREP_TRADITIONAL case `"$ac_path_EGREP_TRADITIONAL" --version 2>&1` in #( *GNU*) ac_cv_path_EGREP_TRADITIONAL="$ac_path_EGREP_TRADITIONAL" ac_path_EGREP_TRADITIONAL_found=:;; #( *) ac_count=0 printf %s 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" printf "%s\n" 'EGREP_TRADITIONAL' >> "conftest.nl" "$ac_path_EGREP_TRADITIONAL" -E 'EGR(EP|AC)_TRADITIONAL$' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_EGREP_TRADITIONAL_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_EGREP_TRADITIONAL="$ac_path_EGREP_TRADITIONAL" ac_path_EGREP_TRADITIONAL_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_EGREP_TRADITIONAL_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_EGREP_TRADITIONAL"; then : fi else ac_cv_path_EGREP_TRADITIONAL=$EGREP_TRADITIONAL fi if test "$ac_cv_path_EGREP_TRADITIONAL" then : ac_cv_path_EGREP_TRADITIONAL="$ac_cv_path_EGREP_TRADITIONAL -E" else case e in #( e) if test -z "$EGREP_TRADITIONAL"; then ac_path_EGREP_TRADITIONAL_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_prog in egrep do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP_TRADITIONAL="$as_dir$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_EGREP_TRADITIONAL" || continue # Check for GNU ac_path_EGREP_TRADITIONAL and select it if it is found. # Check for GNU $ac_path_EGREP_TRADITIONAL case `"$ac_path_EGREP_TRADITIONAL" --version 2>&1` in #( *GNU*) ac_cv_path_EGREP_TRADITIONAL="$ac_path_EGREP_TRADITIONAL" ac_path_EGREP_TRADITIONAL_found=:;; #( *) ac_count=0 printf %s 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" printf "%s\n" 'EGREP_TRADITIONAL' >> "conftest.nl" "$ac_path_EGREP_TRADITIONAL" 'EGR(EP|AC)_TRADITIONAL$' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_EGREP_TRADITIONAL_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_EGREP_TRADITIONAL="$ac_path_EGREP_TRADITIONAL" ac_path_EGREP_TRADITIONAL_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_EGREP_TRADITIONAL_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_EGREP_TRADITIONAL"; then as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_EGREP_TRADITIONAL=$EGREP_TRADITIONAL fi ;; esac fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP_TRADITIONAL" >&5 printf "%s\n" "$ac_cv_path_EGREP_TRADITIONAL" >&6; } EGREP_TRADITIONAL=$ac_cv_path_EGREP_TRADITIONAL if test "${TEA_PLATFORM}" = "windows" -a "$GCC" != "yes"; then MAKE_STATIC_LIB="\${STLIB_LD} -out:\$@ \$(PKG_OBJECTS)" MAKE_SHARED_LIB="\${SHLIB_LD} \${LDFLAGS} \${LDFLAGS_DEFAULT} -out:\$@ \$(PKG_OBJECTS) \${SHLIB_LD_LIBS}" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #if defined(_MSC_VER) && _MSC_VER >= 1400 print("manifest needed") #endif _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP_TRADITIONAL "manifest needed" >/dev/null 2>&1 then : # Could do a CHECK_PROG for mt, but should always be with MSVC8+ VC_MANIFEST_EMBED_DLL="if test -f \$@.manifest ; then mt.exe -nologo -manifest \$@.manifest -outputresource:\$@\;2 ; fi" VC_MANIFEST_EMBED_EXE="if test -f \$@.manifest ; then mt.exe -nologo -manifest \$@.manifest -outputresource:\$@\;1 ; fi" MAKE_SHARED_LIB="${MAKE_SHARED_LIB} ; ${VC_MANIFEST_EMBED_DLL}" CLEANFILES="$CLEANFILES *.manifest" fi rm -rf conftest* MAKE_STUB_LIB="\${STLIB_LD} -nodefaultlib -out:\$@ \$(PKG_STUB_OBJECTS)" else MAKE_STATIC_LIB="\${STLIB_LD} \$@ \$(PKG_OBJECTS)" MAKE_SHARED_LIB="\${SHLIB_LD} \${LDFLAGS} \${LDFLAGS_DEFAULT} -o \$@ \$(PKG_OBJECTS) \${SHLIB_LD_LIBS}" MAKE_STUB_LIB="\${STLIB_LD} \$@ \$(PKG_STUB_OBJECTS)" fi if test "${SHARED_BUILD}" = "1" ; then MAKE_LIB="${MAKE_SHARED_LIB} " else MAKE_LIB="${MAKE_STATIC_LIB} " fi #-------------------------------------------------------------------- # Shared libraries and static libraries have different names. # Use the double eval to make sure any variables in the suffix is # substituted. (@@@ Might not be necessary anymore) #-------------------------------------------------------------------- PACKAGE_LIB_PREFIX8="${PACKAGE_LIB_PREFIX}" PACKAGE_LIB_PREFIX9="${PACKAGE_LIB_PREFIX}tcl9" if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tcl8}" = x; then PACKAGE_LIB_PREFIX="${PACKAGE_LIB_PREFIX9}" else PACKAGE_LIB_PREFIX="${PACKAGE_LIB_PREFIX8}" printf "%s\n" "#define TCL_MAJOR_VERSION 8" >>confdefs.h fi if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tk8}" != x; then printf "%s\n" "#define TK_MAJOR_VERSION 8" >>confdefs.h fi if test "${TEA_PLATFORM}" = "windows" ; then if test "${SHARED_BUILD}" = "1" ; then # We force the unresolved linking of symbols that are really in # the private libraries of Tcl and Tk. if test x"${TK_BIN_DIR}" != x ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TK_BIN_DIR}/${TK_STUB_LIB_FILE}`\"" fi SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \"`${CYGPATH} ${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}`\"" if test "$GCC" = "yes"; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -static-libgcc" fi eval eval "PKG_LIB_FILE8=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE9=${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" else if test "$GCC" = "yes"; then PACKAGE_LIB_PREFIX=lib${PACKAGE_LIB_PREFIX} fi eval eval "PKG_LIB_FILE8=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE9=${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE=${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" fi # Some packages build their own stubs libraries if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tcl8}" = x; then eval eval "PKG_STUB_LIB_FILE=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub.a" else eval eval "PKG_STUB_LIB_FILE=${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" fi if test "$GCC" = "yes"; then PKG_STUB_LIB_FILE=lib${PKG_STUB_LIB_FILE} fi # These aren't needed on Windows (either MSVC or gcc) RANLIB=: RANLIB_STUB=: else RANLIB_STUB="${RANLIB}" if test "${SHARED_BUILD}" = "1" ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TCL_STUB_LIB_SPEC}" if test x"${TK_BIN_DIR}" != x ; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} ${TK_STUB_LIB_SPEC}" fi eval eval "PKG_LIB_FILE8=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE9=lib${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${SHARED_LIB_SUFFIX}" RANLIB=: else eval eval "PKG_LIB_FILE8=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE9=lib${PACKAGE_LIB_PREFIX9}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" eval eval "PKG_LIB_FILE=lib${PACKAGE_LIB_PREFIX}${PACKAGE_NAME}${UNSHARED_LIB_SUFFIX}" fi # Some packages build their own stubs libraries if test "${TCL_MAJOR_VERSION}" -gt 8 -a x"${with_tcl8}" = x; then eval eval "PKG_STUB_LIB_FILE=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub.a" else eval eval "PKG_STUB_LIB_FILE=lib${PACKAGE_LIB_PREFIX8}${PACKAGE_NAME}stub${UNSHARED_LIB_SUFFIX}" fi fi # These are escaped so that only CFLAGS is picked up at configure time. # The other values will be substituted at make time. CFLAGS="${CFLAGS} \${CFLAGS_DEFAULT} \${CFLAGS_WARNING}" if test "${SHARED_BUILD}" = "1" ; then CFLAGS="${CFLAGS} \${SHLIB_CFLAGS}" fi # Substitute STUB_LIB_FILE in case package creates a stub library too. #-------------------------------------------------------------------- # Determine the name of the tclsh and/or wish executables in the # Tcl and Tk build directories or the location they were installed # into. These paths are used to support running test cases only, # the Makefile should not be making use of these paths to generate # a pkgIndex.tcl file or anything else at extension build time. #-------------------------------------------------------------------- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for tclsh" >&5 printf %s "checking for tclsh... " >&6; } if test -f "${TCL_BIN_DIR}/Makefile" ; then # tclConfig.sh is in Tcl build directory if test "${TEA_PLATFORM}" = "windows"; then if test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}" ; then TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}" elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}s${EXEEXT}" ; then TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}s${EXEEXT}" elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}t${EXEEXT}" ; then TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}t${EXEEXT}" elif test -f "${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}st${EXEEXT}" ; then TCLSH_PROG="${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}st${EXEEXT}" fi else TCLSH_PROG="${TCL_BIN_DIR}/tclsh" fi else # tclConfig.sh is in install location if test "${TEA_PLATFORM}" = "windows"; then TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}" else TCLSH_PROG="tclsh${TCL_MAJOR_VERSION}.${TCL_MINOR_VERSION}" fi list="`ls -d ${TCL_BIN_DIR}/../bin 2>/dev/null` \ `ls -d ${TCL_BIN_DIR}/.. 2>/dev/null` \ `ls -d ${TCL_PREFIX}/bin 2>/dev/null`" for i in $list ; do if test -f "$i/${TCLSH_PROG}" ; then REAL_TCL_BIN_DIR="`cd "$i"; pwd`/" break fi done TCLSH_PROG="${REAL_TCL_BIN_DIR}${TCLSH_PROG}" fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${TCLSH_PROG}" >&5 printf "%s\n" "${TCLSH_PROG}" >&6; } #TEA_PROG_WISH #-------------------------------------------------------------------- # Zipfs support - Tip 430 #-------------------------------------------------------------------- # Check whether --enable-zipfs was given. if test ${enable_zipfs+y} then : enableval=$enable_zipfs; tcl_ok=$enableval else case e in #( e) tcl_ok=yes ;; esac fi if test "$tcl_ok" = "yes" -a "x$enable_framework" != "xyes"; then ZIPFS_BUILD=1 THREAD_ZIP_FILE=lib${PACKAGE_NAME}${PACKAGE_VERSION}.zip else ZIPFS_BUILD=0 THREAD_ZIP_FILE= fi # Do checking message here to not mess up interleaved configure output { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5 printf %s "checking for building with zipfs... " >&6; } if test "${ZIPFS_BUILD}" = 1; then if test "${SHARED_BUILD}" = 0; then ZIPFS_BUILD=2; printf "%s\n" "#define ZIPFS_BUILD 2" >>confdefs.h INSTALL_LIBRARIES=install-demos { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else printf "%s\n" "#define ZIPFS_BUILD 1" >>confdefs.h \ INSTALL_LIBRARIES=install-demos { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } INSTALL_LIBRARIES=install-libraries INSTALL_MSGS=install-msgs fi #-------------------------------------------------------------------- # Finally, substitute all of the various values into the Makefile. # You may alternatively have a special pkgIndex.tcl.in or other files # which require substituting th AC variables in. Include these here. #-------------------------------------------------------------------- ac_config_files="$ac_config_files Makefile pkgIndex.tcl" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # 'ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* 'ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # 'set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # 'set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test ${\1+y} || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 printf "%s\n" "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 printf "%s\n" "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[][ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`printf "%s\n" "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS="" : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case e in #( e) case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac ;; esac fi # Reset variables that may have inherited troublesome values from # the environment. # IFS needs to be set, to space, tab, and newline, in precisely that order. # (If _AS_PATH_WALK were called with IFS unset, it would have the # side effect of setting IFS to empty, thus disabling word splitting.) # Quoting is to prevent editors from complaining about space-tab. as_nl=' ' export as_nl IFS=" "" $as_nl" PS1='$ ' PS2='> ' PS4='+ ' # Ensure predictable behavior from utilities with locale-dependent output. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # We cannot yet rely on "unset" to work, but we need these variables # to be unset--not just set to an empty or harmless value--now, to # avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct # also avoids known problems related to "unset" and subshell syntax # in other old shells (e.g. bash 2.01 and pdksh 5.2.14). for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH do eval test \${$as_var+y} \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done # Ensure that fds 0, 1, and 2 are open. if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi if (exec 3>&2) ; then :; else exec 2>/dev/null; fi # The user is always right. if ${PATH_SEPARATOR+false} :; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac test -r "$as_dir$0" && as_myself=$as_dir$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as 'sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi printf "%s\n" "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null then : eval 'as_fn_append () { eval $1+=\$2 }' else case e in #( e) as_fn_append () { eval $1=\$$1\$2 } ;; esac fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null then : eval 'as_fn_arith () { as_val=$(( $* )) }' else case e in #( e) as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } ;; esac fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits # Determine whether it's possible to make 'echo' print without a newline. # These variables are no longer used directly by Autoconf, but are AC_SUBSTed # for compatibility with existing Makefiles. ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac # For backward compatibility with old third-party macros, we provide # the shell variables $as_echo and $as_echo_n. New code should use # AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. as_echo='printf %s\n' as_echo_n='printf %s' rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both 'ln -s file dir' and 'ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; 'ln -s' creates a wrapper executable. # In both cases, we have to default to 'cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_sed_cpp="y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" as_tr_cpp="eval sed '$as_sed_cpp'" # deprecated # Sed expression to map a string onto a valid variable name. as_sed_sh="y%*+%pp%;s%[^_$as_cr_alnum]%_%g" as_tr_sh="eval sed '$as_sed_sh'" # deprecated exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by thread $as_me 3.0.1, which was generated by GNU Autoconf 2.72. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ '$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to the package provider." _ACEOF ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ thread config.status 3.0.1 configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" Copyright (C) 2023 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) printf "%s\n" "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) printf "%s\n" "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) printf "%s\n" "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: '$1' Try '$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \printf "%s\n" "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX printf "%s\n" "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "pkgIndex.tcl") CONFIG_FILES="$CONFIG_FILES pkgIndex.tcl" ;; *) as_fn_error $? "invalid argument: '$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test ${CONFIG_FILES+y} || CONFIG_FILES=$config_files fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to '$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with './config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" eval set X " :F $CONFIG_FILES " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag '$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain ':'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: '$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is 'configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 printf "%s\n" "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`printf "%s\n" "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 printf "%s\n" "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when '$srcdir' = '.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable 'datarootdir' which seems to be undefined. Please make sure it is defined" >&5 printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable 'datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi thread3.0.1/naviserver.m40000644003604700454610000000301214726633451013735 0ustar dgp771div #------------------------------------------------------------------------ # NS_PATH_AOLSERVER # # Allows the building with support for NaviServer/AOLserver # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --with-naviserver=... # # Defines the following vars: # NS_DIR Full path to the directory containing NaviServer/AOLserver distro # NS_INCLUDES # NS_LIBS # # Sets the following vars: # NS_AOLSERVER # # Updates following vars: #------------------------------------------------------------------------ AC_DEFUN(NS_PATH_AOLSERVER, [ AC_MSG_CHECKING([for NaviServer/AOLserver configuration]) AC_ARG_WITH(naviserver, [ --with-naviserver directory with NaviServer/AOLserver distribution],\ with_naviserver=${withval}) AC_CACHE_VAL(ac_cv_c_naviserver,[ if test x"${with_naviserver}" != x ; then if test -f "${with_naviserver}/include/ns.h" ; then ac_cv_c_naviserver=`(cd ${with_naviserver}; pwd)` else AC_MSG_ERROR([${with_naviserver} directory doesn't contain ns.h]) fi fi ]) if test x"${ac_cv_c_naviserver}" = x ; then AC_MSG_RESULT([none found]) else NS_DIR=${ac_cv_c_naviserver} AC_MSG_RESULT([found NaviServer/AOLserver in $NS_DIR]) NS_INCLUDES="-I\"${NS_DIR}/include\"" if test "`uname -s`" = Darwin ; then aollibs=`ls ${NS_DIR}/lib/libns* 2>/dev/null` if test x"$aollibs" != x ; then NS_LIBS="-L\"${NS_DIR}/lib\" -lnsd -lnsthread" fi fi AC_DEFINE(NS_AOLSERVER) fi ]) # EOF thread3.0.1/pkgIndex.tcl.in0000644003604700454610000000420114726633451014172 0ustar dgp771div# -*- tcl -*- # Tcl package index file, version 1.1 # # Tcl 8.7 interps are only supported on 32-bit platforms. # Lower than that is never supported. Bye! if {![package vsatisfies [package provide Tcl] 9.0] && ((![package vsatisfies [package provide Tcl] 8.7]) || ($::tcl_platform(pointerSize)!=4))} { return } # All Tcl 8.7+ interps can [load] thread @PACKAGE_VERSION@ # # For interps that are not thread-enabled, we still call [package ifneeded]. # This is contrary to the usual convention, but is a good idea because we # cannot imagine any other version of thread that might succeed in a # thread-disabled interp. There's nothing to gain by yielding to other # competing callers of [package ifneeded Thread]. On the other hand, # deferring the error has the advantage that a script calling # [package require Thread] in a thread-disabled interp gets an error message # about a thread-disabled interp, instead of the message # "can't find package thread". package ifneeded [string tolower @PACKAGE_NAME@] @PACKAGE_VERSION@ \ [list load [file join $dir @PKG_LIB_FILE@] [string totitle @PACKAGE_NAME@]] package ifneeded [string totitle @PACKAGE_NAME@] @PACKAGE_VERSION@ \ [list package require -exact [string tolower @PACKAGE_NAME@] @PACKAGE_VERSION@] # package ttrace uses some support machinery. # In Tcl 8.7+ interps; use [::apply] package ifneeded ttrace @PACKAGE_VERSION@ [list ::apply {{dir} { if {[info exists ::env(TCL_THREAD_LIBRARY)] && [file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} { source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl } elseif {[file readable [file join $dir .. lib ttrace.tcl]]} { source [file join $dir .. lib ttrace.tcl] } elseif {[file readable [file join $dir ttrace.tcl]]} { source [file join $dir ttrace.tcl] } elseif {[file exists //zipfs:/lib/thread/ttrace.tcl] || ![catch {zipfs mount [file join $dir @PKG_LIB_FILE@] //zipfs:/lib/thread}]} { source //zipfs:/lib/thread/ttrace.tcl } if {[namespace which ::ttrace::update] ne ""} { ::ttrace::update } }} $dir] package ifneeded Ttrace @PACKAGE_VERSION@ \ [list package require -exact ttrace @PACKAGE_VERSION@] thread3.0.1/Makefile.in0000644003604700454610000004477314726633451013377 0ustar dgp771div# Makefile.in -- # # This file is a Makefile for the thread Extension. If it has the name # "Makefile.in" then it is a template for a Makefile; to generate the # actual Makefile, run "./configure", which is a configuration script # generated by the "autoconf" program (constructs like "@foo@" will get # replaced in the actual Makefile. # # Copyright (c) 1999 Scriptics Corporation. # Copyright (c) 2002-2005 ActiveState Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #======================================================================== # Add additional lines to handle any additional AC_SUBST cases that # have been added in a customized configure script. #======================================================================== #SAMPLE_NEW_VAR = @SAMPLE_NEW_VAR@ #======================================================================== # Nothing of the variables below this line should need to be changed. # Please check the TARGETS section below to make sure the make targets # are correct. #======================================================================== #======================================================================== # The names of the source files is defined in the configure script. # The object files are used for linking into the final library. # This will be used when a dist target is added to the Makefile. # It is not important to specify the directory, as long as it is the # $(srcdir) or in the generic, win or unix subdirectory. #======================================================================== PKG_SOURCES = @PKG_SOURCES@ PKG_OBJECTS = @PKG_OBJECTS@ PKG_STUB_SOURCES = @PKG_STUB_SOURCES@ PKG_STUB_OBJECTS = @PKG_STUB_OBJECTS@ #======================================================================== # PKG_TCL_SOURCES identifies Tcl runtime files that are associated with # this package that need to be installed, if any. #======================================================================== PKG_TCL_SOURCES = @PKG_TCL_SOURCES@ #======================================================================== # This is a list of public header files to be installed, if any. #======================================================================== PKG_HEADERS = @PKG_HEADERS@ #======================================================================== # "PKG_LIB_FILE" refers to the library (dynamic or static as per # configuration options) composed of the named objects. #======================================================================== PKG_LIB_FILE = @PKG_LIB_FILE@ PKG_LIB_FILE8 = @PKG_LIB_FILE8@ PKG_LIB_FILE9 = @PKG_LIB_FILE9@ PKG_STUB_LIB_FILE = @PKG_STUB_LIB_FILE@ lib_BINARIES = $(PKG_LIB_FILE) BINARIES = $(lib_BINARIES) SHELL = @SHELL@ srcdir = @srcdir@ prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ runstatedir = @runstatedir@ datadir = @datadir@ mandir = @mandir@ DESTDIR = PKG_DIR = $(PACKAGE_NAME)$(PACKAGE_VERSION) pkgdatadir = $(datadir)/$(PKG_DIR) pkglibdir = $(libdir)/$(PKG_DIR) pkgincludedir = $(includedir)/$(PKG_DIR) top_builddir = @abs_top_builddir@ ### # Tip 430 - ZipFS Modifications ### THREAD_ZIP_FILE = @THREAD_ZIP_FILE@ THREAD_VFS_ROOT = libthread.vfs THREAD_VFS_PATH = ${THREAD_VFS_ROOT}/thread_library ZIPFS_BUILD = @ZIPFS_BUILD@ SHARED_BUILD = @SHARED_BUILD@ INSTALL_LIBRARIES = @INSTALL_LIBRARIES@ INSTALL_MSGS = @INSTALL_MSGS@ INSTALL_OPTIONS = INSTALL = @INSTALL@ $(INSTALL_OPTIONS) INSTALL_DATA_DIR = @INSTALL_DATA_DIR@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_LIBRARY = @INSTALL_LIBRARY@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_VERSION = @PACKAGE_VERSION@ CC = @CC@ CCLD = @CCLD@ CFLAGS_DEFAULT = @CFLAGS_DEFAULT@ CFLAGS_WARNING = @CFLAGS_WARNING@ EXEEXT = @EXEEXT@ LDFLAGS_DEFAULT = @LDFLAGS_DEFAULT@ MAKE_LIB = @MAKE_LIB@ MAKE_STUB_LIB = @MAKE_STUB_LIB@ OBJEXT = @OBJEXT@ RANLIB = @RANLIB@ RANLIB_STUB = @RANLIB_STUB@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_LD = @SHLIB_LD@ SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ STLIB_LD = @STLIB_LD@ #TCL_DEFS = @TCL_DEFS@ TCL_BIN_DIR = @TCL_BIN_DIR@ TCL_SRC_DIR = @TCL_SRC_DIR@ #TK_BIN_DIR = @TK_BIN_DIR@ #TK_SRC_DIR = @TK_SRC_DIR@ # Not used, but retained for reference of what libs Tcl required #TCL_LIBS = @TCL_LIBS@ #======================================================================== # TCLLIBPATH seeds the auto_path in Tcl's init.tcl so we can test our # package without installing. The other environment variables allow us # to test against an uninstalled Tcl. Add special env vars that you # require for testing here (like TCLX_LIBRARY). #======================================================================== EXTRA_PATH = $(top_builddir):$(TCL_BIN_DIR) #EXTRA_PATH = $(top_builddir):$(TCL_BIN_DIR):$(TK_BIN_DIR) TCLLIBPATH = $(top_builddir) TCLSH_ENV = TCL_LIBRARY=`@CYGPATH@ $(TCL_SRC_DIR)/library` PKG_ENV = TCL_THREAD_LIBRARY=`@CYGPATH@ $(srcdir)/lib` \ @LD_LIBRARY_PATH_VAR@="$(EXTRA_PATH):$(@LD_LIBRARY_PATH_VAR@)" \ PATH="$(EXTRA_PATH):$(PATH)" \ TCLLIBPATH="$(TCLLIBPATH) $(top_builddir)/../lib" TCLSH_PROG = @TCLSH_PROG@ TCLSH = $(TCLSH_ENV) $(PKG_ENV) $(TCLSH_PROG) #WISH_ENV = TK_LIBRARY=`@CYGPATH@ $(TK_SRC_DIR)/library` #WISH_PROG = @WISH_PROG@ #WISH = $(TCLSH_ENV) $(WISH_ENV) $(PKG_ENV) $(WISH_PROG) SHARED_BUILD = @SHARED_BUILD@ INCLUDES = @PKG_INCLUDES@ @TCL_INCLUDES@ -I. #INCLUDES = @PKG_INCLUDES@ @TCL_INCLUDES@ @TK_INCLUDES@ @TK_XINCLUDES@ PKG_CFLAGS = @PKG_CFLAGS@ # TCL_DEFS is not strictly need here, but if you remove it, then you # must make sure that configure.ac checks for the necessary components # that your library may use. TCL_DEFS can actually be a problem if # you do not compile with a similar machine setup as the Tcl core was # compiled with. #DEFS = $(TCL_DEFS) @DEFS@ $(PKG_CFLAGS) DEFS = @DEFS@ $(PKG_CFLAGS) # Move pkgIndex.tcl to 'BINARIES' var if it is generated in the Makefile CONFIG_CLEAN_FILES = Makefile pkgIndex.tcl CLEANFILES = @CLEANFILES@ CPPFLAGS = @CPPFLAGS@ LIBS = @PKG_LIBS@ @LIBS@ AR = @AR@ CFLAGS = @CFLAGS@ LDFLAGS = @LDFLAGS@ LDFLAGS_DEFAULT = @LDFLAGS_DEFAULT@ COMPILE = $(CC) $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) \ $(CFLAGS_DEFAULT) $(CFLAGS_WARNING) $(SHLIB_CFLAGS) $(CFLAGS) GDB = gdb VALGRIND = valgrind VALGRINDARGS = --tool=memcheck --num-callers=8 --leak-resolution=high \ --leak-check=yes --show-reachable=yes -v .SUFFIXES: .c .$(OBJEXT) #======================================================================== # Start of user-definable TARGETS section #======================================================================== #======================================================================== # TEA TARGETS. Please note that the "libraries:" target refers to platform # independent files, and the "binaries:" target includes executable programs and # platform-dependent libraries. Modify these targets so that they install # the various pieces of your package. The make and install rules # for the BINARIES that you specified above have already been done. #======================================================================== all: binaries libraries doc #======================================================================== # The binaries target builds executable programs, Windows .dll's, unix # shared/static libraries, and any other platform-dependent files. # The list of targets to build for "binaries:" is specified at the top # of the Makefile, in the "BINARIES" variable. #======================================================================== binaries: $(BINARIES) libraries: threadzipfile: ${THREAD_ZIP_FILE} ${THREAD_ZIP_FILE}: ${ZIP_INSTALL_OBJS} @rm -rf ${THREAD_VFS_ROOT} @mkdir -p ${THREAD_VFS_PATH} @echo "creating ${THREAD_VFS_PATH} (prepare compression)" @cp -a $(srcdir)/lib/* ${THREAD_VFS_PATH}; @find ${THREAD_VFS_ROOT} -type d -empty -delete @echo "creating ${THREAD_ZIP_FILE} from ${THREAD_VFS_PATH}" @echo "zipfs mkzip ${THREAD_ZIP_FILE} ${THREAD_VFS_PATH} ${THREAD_VFS_PATH}" | $(TCLSH) #======================================================================== # Your doc target should differentiate from doc builds (by the developer) # and doc installs (see install-doc), which just install the docs on the # end user machine when building from source. #======================================================================== doc: install: all install-binaries install-libraries install-doc install-binaries: binaries install-lib-binaries install-bin-binaries #======================================================================== # This rule installs platform-independent files, such as header files. # The list=...; for p in $$list handles the empty list case x-platform. #======================================================================== install-libraries: libraries @$(INSTALL_DATA_DIR) "$(DESTDIR)$(includedir)" @echo "Installing header files in $(DESTDIR)$(includedir)" @list='$(PKG_HEADERS)'; for i in $$list; do \ echo "Installing $(srcdir)/$$i" ; \ $(INSTALL_DATA) $(srcdir)/$$i "$(DESTDIR)$(includedir)" ; \ done; #======================================================================== # Install documentation. Unix manpages should go in the $(mandir) # directory. #======================================================================== install-doc: doc @$(INSTALL_DATA_DIR) "$(DESTDIR)$(mandir)/mann" @echo "Installing documentation in $(DESTDIR)$(mandir)" @list='$(srcdir)/doc/man/*.n'; for i in $$list; do \ echo "Installing $$i"; \ $(INSTALL_DATA) $$i "$(DESTDIR)$(mandir)/mann" ; \ done test: binaries libraries $(TCLSH) `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS) \ -load "package ifneeded $(PACKAGE_NAME) $(PACKAGE_VERSION) \ [list load `@CYGPATH@ $(PKG_LIB_FILE)` [string totitle $(PACKAGE_NAME)]]" shell: binaries libraries @$(TCLSH) $(SCRIPT) gdb: $(TCLSH_ENV) $(PKG_ENV) $(GDB) $(TCLSH_PROG) $(SCRIPT) gdb-test: binaries libraries $(TCLSH_ENV) $(PKG_ENV) $(GDB) \ --args $(TCLSH_PROG) `@CYGPATH@ $(srcdir)/tests/all.tcl` \ $(TESTFLAGS) -singleproc 1 \ -load "package ifneeded Thread $(PACKAGE_VERSION) \ [list load `@CYGPATH@ $(PKG_LIB_FILE)` [string totitle $(PACKAGE_NAME)]]" valgrind: binaries libraries $(TCLSH_ENV) $(PKG_ENV) $(VALGRIND) $(VALGRINDARGS) $(TCLSH_PROG) \ `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS) valgrindshell: binaries libraries $(TCLSH_ENV) $(PKG_ENV) $(VALGRIND) $(VALGRINDARGS) $(TCLSH_PROG) $(SCRIPT) depend: #======================================================================== # $(PKG_LIB_FILE) should be listed as part of the BINARIES variable # mentioned above. That will ensure that this target is built when you # run "make binaries". # # The $(PKG_OBJECTS) objects are created and linked into the final # library. In most cases these object files will correspond to the # source files above. #======================================================================== $(PKG_LIB_FILE): $(PKG_OBJECTS) ${THREAD_ZIP_FILE} -rm -f $(PKG_LIB_FILE) ${MAKE_LIB} @if test "${ZIPFS_BUILD}" = "1" ; then \ cat ${THREAD_ZIP_FILE} >> ${PKG_LIB_FILE}; \ fi $(PKG_STUB_LIB_FILE): $(PKG_STUB_OBJECTS) -rm -f $(PKG_STUB_LIB_FILE) ${MAKE_STUB_LIB} $(RANLIB_STUB) $(PKG_STUB_LIB_FILE) #======================================================================== # We need to enumerate the list of .c to .o lines here. # # In the following lines, $(srcdir) refers to the toplevel directory # containing your extension. If your sources are in a subdirectory, # you will have to modify the paths to reflect this: # # sample.$(OBJEXT): $(srcdir)/generic/sample.c # $(COMPILE) -c `@CYGPATH@ $(srcdir)/generic/sample.c` -o $@ # # Setting the VPATH variable to a list of paths will cause the makefile # to look into these paths when resolving .c to .obj dependencies. # As necessary, add $(srcdir):$(srcdir)/compat:.... #======================================================================== VPATH = $(srcdir):$(srcdir)/generic:$(srcdir)/unix:$(srcdir)/win:$(srcdir)/macosx .c.@OBJEXT@: $(COMPILE) -c `@CYGPATH@ $<` -o $@ threadCmd.@OBJEXT@: threadUuid.h $(srcdir)/manifest.uuid: printf "git-" >$(srcdir)/manifest.uuid (cd $(srcdir); git rev-parse HEAD >>$(srcdir)/manifest.uuid || \ (printf "svn-r" >$(srcdir)/manifest.uuid ; \ svn info --show-item last-changed-revision >>$(srcdir)/manifest.uuid) || \ printf "unknown" >$(srcdir)/manifest.uuid) threadUuid.h: $(srcdir)/manifest.uuid echo "#define THREAD_VERSION_UUID \\" >$@ cat $(srcdir)/manifest.uuid >>$@ echo "" >>$@ #======================================================================== # Distribution creation # You may need to tweak this target to make it work correctly. #======================================================================== #COMPRESS = tar cvf $(PKG_DIR).tar $(PKG_DIR); compress $(PKG_DIR).tar COMPRESS = tar zcvf $(PKG_DIR).tar.gz $(PKG_DIR) DIST_ROOT = /tmp/dist DIST_DIR = $(DIST_ROOT)/$(PKG_DIR) DIST_INSTALL_DATA = CPPROG='cp -p' $(INSTALL) -m 644 DIST_INSTALL_SCRIPT = CPPROG='cp -p' $(INSTALL) -m 755 dist-clean: rm -rf $(DIST_DIR) $(DIST_ROOT)/$(PKG_DIR).tar.* dist: dist-clean $(srcdir)/manifest.uuid $(INSTALL_DATA_DIR) $(DIST_DIR) $(DIST_INSTALL_DATA) $(srcdir)/license.terms \ $(srcdir)/manifest.uuid \ $(srcdir)/ChangeLog $(srcdir)/README \ $(srcdir)/aclocal.m4 $(srcdir)/configure.ac \ $(srcdir)/Makefile.in $(srcdir)/pkgIndex.tcl.in \ $(srcdir)/naviserver.m4 \ $(DIST_DIR)/ $(DIST_INSTALL_SCRIPT) $(srcdir)/configure $(DIST_DIR)/ $(INSTALL_DATA_DIR) $(DIST_DIR)/tclconfig $(DIST_INSTALL_DATA) $(srcdir)/tclconfig/README.txt \ $(srcdir)/tclconfig/tcl.m4 $(srcdir)/tclconfig/install-sh \ $(DIST_DIR)/tclconfig/ $(INSTALL_DATA_DIR) $(DIST_DIR)/unix $(DIST_INSTALL_DATA) $(srcdir)/unix/README $(srcdir)/unix/CONFIG \ $(srcdir)/unix/threadUnix.c \ $(DIST_DIR)/unix/ $(INSTALL_DATA_DIR) $(DIST_DIR)/win $(DIST_INSTALL_DATA) \ $(srcdir)/win/README.txt $(srcdir)/win/CONFIG $(srcdir)/win/thread.rc \ $(srcdir)/win/*.vc $(srcdir)/win/*.in \ $(srcdir)/win/nmakehlp.c $(srcdir)/win/thread_win.dsw \ $(srcdir)/win/thread_win.dsp \ $(DIST_DIR)/win/ $(INSTALL_DATA_DIR) $(DIST_DIR)/tcl $(DIST_INSTALL_DATA) $(srcdir)/tcl/README $(DIST_DIR)/tcl/ list='tests doc doc/man doc/html generic lib tcl/cmdsrv tcl/phttpd tcl/tpool';\ for p in $$list; do \ if test -d $(srcdir)/$$p ; then \ $(INSTALL_DATA_DIR) $(DIST_DIR)/$$p; \ $(DIST_INSTALL_DATA) $(srcdir)/$$p/*.* $(DIST_DIR)/$$p/; \ fi; \ done (cd $(DIST_ROOT); $(COMPRESS);) #======================================================================== # End of user-definable section #======================================================================== #======================================================================== # Don't modify the file to clean here. Instead, set the "CLEANFILES" # variable in configure.ac #======================================================================== clean: -test -z "$(BINARIES)" || rm -f $(BINARIES) -rm -f *.$(OBJEXT) core *.core -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) distclean: clean -rm -f *.tab.c -rm -f $(CONFIG_CLEAN_FILES) -rm -f config.cache config.log config.status #======================================================================== # Install binary object libraries. On Windows this includes both .dll and # .lib files. Because the .lib files are not explicitly listed anywhere, # we need to deduce their existence from the .dll file of the same name. # Library files go into the lib directory. # In addition, this will generate the pkgIndex.tcl # file in the install location (assuming it can find a usable tclsh shell) # # You should not have to modify this target. #======================================================================== install-lib-binaries: binaries @$(INSTALL_DATA_DIR) "$(DESTDIR)$(pkglibdir)" @list='$(lib_BINARIES)'; for p in $$list; do \ if test -f $$p; then \ echo " $(INSTALL_LIBRARY) $$p $(DESTDIR)$(pkglibdir)/$$p"; \ $(INSTALL_LIBRARY) $$p "$(DESTDIR)$(pkglibdir)/$$p"; \ stub=`echo $$p|sed -e "s/.*\(stub\).*/\1/"`; \ if test "x$$stub" = "xstub"; then \ echo " $(RANLIB_STUB) $(DESTDIR)$(pkglibdir)/$$p"; \ $(RANLIB_STUB) "$(DESTDIR)$(pkglibdir)/$$p"; \ else \ echo " $(RANLIB) $(DESTDIR)$(pkglibdir)/$$p"; \ $(RANLIB) "$(DESTDIR)$(pkglibdir)/$$p"; \ fi; \ ext=`echo $$p|sed -e "s/.*\.//"`; \ if test "x$$ext" = "xdll"; then \ lib=`basename $$p|sed -e 's/.[^.]*$$//'`.lib; \ if test -f $$lib; then \ echo " $(INSTALL_DATA) $$lib $(DESTDIR)$(pkglibdir)/$$lib"; \ $(INSTALL_DATA) $$lib "$(DESTDIR)$(pkglibdir)/$$lib"; \ fi; \ fi; \ fi; \ done @if test "${ZIPFS_BUILD}" = "0" ; then \ list='$(PKG_TCL_SOURCES)'; for p in $$list; do \ if test -f $(srcdir)/$$p; then \ destp=`basename $$p`; \ echo " Install $$destp $(DESTDIR)$(pkglibdir)/$$destp"; \ $(INSTALL_DATA) $(srcdir)/$$p "$(DESTDIR)$(pkglibdir)/$$destp"; \ fi; \ done; \ fi; @if test "x$(SHARED_BUILD)" = "x1"; then \ echo " Install pkgIndex.tcl $(DESTDIR)$(pkglibdir)"; \ $(INSTALL_DATA) pkgIndex.tcl "$(DESTDIR)$(pkglibdir)"; \ fi #======================================================================== # Install binary executables (e.g. .exe files and dependent .dll files) # This is for files that must go in the bin directory (located next to # wish and tclsh), like dependent .dll files on Windows. # # You should not have to modify this target, except to define bin_BINARIES # above if necessary. #======================================================================== install-bin-binaries: binaries @$(INSTALL_DATA_DIR) "$(DESTDIR)$(bindir)" @list='$(bin_BINARIES)'; for p in $$list; do \ if test -f $$p; then \ echo " $(INSTALL_PROGRAM) $$p $(DESTDIR)$(bindir)/$$p"; \ $(INSTALL_PROGRAM) $$p "$(DESTDIR)$(bindir)/$$p"; \ fi; \ done Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status cd $(top_builddir) \ && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status uninstall-binaries: list='$(lib_BINARIES)'; for p in $$list; do \ rm -f "$(DESTDIR)$(pkglibdir)/$$p"; \ done list='$(PKG_TCL_SOURCES)'; for p in $$list; do \ p=`basename $$p`; \ rm -f "$(DESTDIR)$(pkglibdir)/$$p"; \ done list='$(bin_BINARIES)'; for p in $$list; do \ rm -f "$(DESTDIR)$(bindir)/$$p"; \ done .PHONY: all binaries clean depend distclean doc install libraries test .PHONY: gdb gdb-test valgrind valgrindshell # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: thread3.0.1/configure.ac0000644003604700454610000002325714726633451013612 0ustar dgp771div#!/bin/bash -norc dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. #----------------------------------------------------------------------- # Sample configure.ac for Tcl Extensions. The only places you should # need to modify this file are marked by the string __CHANGE__ #----------------------------------------------------------------------- #----------------------------------------------------------------------- # __CHANGE__ # Set your package name and version numbers here. # # This initializes the environment with PACKAGE_NAME and PACKAGE_VERSION # set as provided. These will also be added as -D defs in your Makefile # so you can encode the package version directly into the source files. #----------------------------------------------------------------------- AC_INIT([thread],[3.0.1]) #-------------------------------------------------------------------- # Call TEA_INIT as the first TEA_ macro to set up initial vars. # This will define a ${TEA_PLATFORM} variable == "unix" or "windows" # as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE. #-------------------------------------------------------------------- TEA_INIT() AC_CONFIG_AUX_DIR(tclconfig) #-------------------------------------------------------------------- # Load the tclConfig.sh file #-------------------------------------------------------------------- TEA_PATH_TCLCONFIG if test x"${with_tcl8}" != x; then with_tcl8="" AC_MSG_WARN([--with-tcl8 option ignored]) fi TEA_LOAD_TCLCONFIG if test "${TCL_MAJOR_VERSION}" -eq 8; then AC_MSG_ERROR([${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 9.0+ Found config for Tcl ${TCL_VERSION}]) fi #-------------------------------------------------------------------- # Load the tkConfig.sh file if necessary (Tk extension) #-------------------------------------------------------------------- #TEA_PATH_TKCONFIG #TEA_LOAD_TKCONFIG #----------------------------------------------------------------------- # Handle the --prefix=... option by defaulting to what Tcl gave. # Must be called after TEA_LOAD_TCLCONFIG and before TEA_SETUP_COMPILER. #----------------------------------------------------------------------- TEA_PREFIX #----------------------------------------------------------------------- # Standard compiler checks. # This sets up CC by using the CC env var, or looks for gcc otherwise. # This also calls AC_PROG_CC and a few others to create the basic setup # necessary to compile executables. #----------------------------------------------------------------------- TEA_SETUP_COMPILER #-------------------------------------------------------------------- # Check if building with optional Gdbm package. This will declare # GDBM_CFLAGS and GDBM_LIBS variables. #-------------------------------------------------------------------- TCLTHREAD_WITH_GDBM #-------------------------------------------------------------------- # Check if building with optional lmdb package. This will declare # LMDB_CFLAGS and LMDB_LIBS variables. #-------------------------------------------------------------------- TCLTHREAD_WITH_LMDB #-------------------------------------------------------------------- # Locate the NaviServer/AOLserver dir for compilation as NaviServer/AOLserver module. # This will declare NS_INCLUDES, NS_LIBS and define NS_AOLSERVER. #-------------------------------------------------------------------- NS_PATH_AOLSERVER #----------------------------------------------------------------------- # __CHANGE__ # Specify the C source files to compile in TEA_ADD_SOURCES, # public headers that need to be installed in TEA_ADD_HEADERS, # stub library C source files to compile in TEA_ADD_STUB_SOURCES, # and runtime Tcl library files in TEA_ADD_TCL_SOURCES. # This defines PKG(_STUB)_SOURCES, PKG(_STUB)_OBJECTS, PKG_HEADERS # and PKG_TCL_SOURCES. #----------------------------------------------------------------------- TEA_ADD_SOURCES([generic/threadNs.c \ generic/threadCmd.c \ generic/threadSvCmd.c \ generic/threadSpCmd.c \ generic/threadPoolCmd.c \ generic/psGdbm.c \ generic/psLmdb.c \ generic/threadSvListCmd.c \ generic/threadSvKeylistCmd.c \ generic/tclXkeylist.c \ ]) TEA_ADD_HEADERS([generic/tclThread.h]) TEA_ADD_INCLUDES([${NS_INCLUDES}]) TEA_ADD_LIBS([${GDBM_LIBS} ${LMDB_LIBS} ${NS_LIBS}]) TEA_ADD_CFLAGS([${GDBM_CFLAGS} ${LMDB_CFLAGS}]) TEA_ADD_STUB_SOURCES([]) TEA_ADD_TCL_SOURCES([lib/ttrace.tcl]) #-------------------------------------------------------------------- # __CHANGE__ # A few miscellaneous platform-specific items: # # Define a special symbol for Windows (BUILD_sample in this case) so # that we create the export library with the dll. # # Windows creates a few extra files that need to be cleaned up. # You can add more files to clean if your extension creates any extra # files. # # TEA_ADD_* any platform specific compiler/build info here. #-------------------------------------------------------------------- if test "${TEA_PLATFORM}" = "windows" ; then TEA_ADD_INCLUDES([-I\"$(${CYGPATH} ${srcdir}/win)\"]) else TEA_ADD_SOURCES([unix/threadUnix.c]) fi #-------------------------------------------------------------------- # __CHANGE__ # Choose which headers you need. Extension authors should try very # hard to only rely on the Tcl public header files. Internal headers # contain private data structures and are subject to change without # notice. # This MUST be called after TEA_LOAD_TCLCONFIG / TEA_LOAD_TKCONFIG #-------------------------------------------------------------------- TEA_PUBLIC_TCL_HEADERS #TEA_PRIVATE_TCL_HEADERS #TEA_PUBLIC_TK_HEADERS #TEA_PRIVATE_TK_HEADERS #TEA_PATH_X #-------------------------------------------------------------------- # Check whether --enable-threads or --disable-threads was given. # This auto-enables if Tcl was compiled threaded. #-------------------------------------------------------------------- TEA_ENABLE_THREADS #-------------------------------------------------------------------- # The statement below defines a collection of symbols related to # building as a shared library instead of a static library. #-------------------------------------------------------------------- TEA_ENABLE_SHARED #-------------------------------------------------------------------- # This macro figures out what flags to use with the compiler/linker # when building shared/static debug/optimized objects. This information # can be taken from the tclConfig.sh file, but this figures it all out. #-------------------------------------------------------------------- TEA_CONFIG_CFLAGS #-------------------------------------------------------------------- # Set the default compiler switches based on the --enable-symbols option. #-------------------------------------------------------------------- TEA_ENABLE_SYMBOLS #-------------------------------------------------------------------- # Everyone should be linking against the Tcl stub library. If you # can't for some reason, remove this definition. If you aren't using # stubs, you also need to modify the SHLIB_LD_LIBS setting below to # link against the non-stubbed Tcl library. Add Tk too if necessary. #-------------------------------------------------------------------- AC_DEFINE(USE_TCL_STUBS, 1, [Use Tcl stubs]) #-------------------------------------------------------------------- # This macro generates a line to use when building a library. It # depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS, # and TEA_LOAD_TCLCONFIG macros above. #-------------------------------------------------------------------- TEA_MAKE_LIB #-------------------------------------------------------------------- # Determine the name of the tclsh and/or wish executables in the # Tcl and Tk build directories or the location they were installed # into. These paths are used to support running test cases only, # the Makefile should not be making use of these paths to generate # a pkgIndex.tcl file or anything else at extension build time. #-------------------------------------------------------------------- TEA_PROG_TCLSH #TEA_PROG_WISH #-------------------------------------------------------------------- # Zipfs support - Tip 430 #-------------------------------------------------------------------- AC_ARG_ENABLE(zipfs, AS_HELP_STRING([--enable-zipfs],[build with Zipfs support (default: on)]), [tcl_ok=$enableval], [tcl_ok=yes]) if test "$tcl_ok" = "yes" -a "x$enable_framework" != "xyes"; then ZIPFS_BUILD=1 THREAD_ZIP_FILE=lib${PACKAGE_NAME}${PACKAGE_VERSION}.zip else ZIPFS_BUILD=0 THREAD_ZIP_FILE= fi # Do checking message here to not mess up interleaved configure output AC_MSG_CHECKING([for building with zipfs]) if test "${ZIPFS_BUILD}" = 1; then if test "${SHARED_BUILD}" = 0; then ZIPFS_BUILD=2; AC_DEFINE(ZIPFS_BUILD, 2, [Are we building with zipfs enabled?]) INSTALL_LIBRARIES=install-demos AC_MSG_RESULT([yes]) else AC_DEFINE(ZIPFS_BUILD, 1, [Are we building with zipfs enabled?])\ INSTALL_LIBRARIES=install-demos AC_MSG_RESULT([yes]) fi else AC_MSG_RESULT([no]) INSTALL_LIBRARIES=install-libraries INSTALL_MSGS=install-msgs fi AC_SUBST(ZIPFS_BUILD) AC_SUBST(THREAD_ZIP_FILE) AC_SUBST(INSTALL_LIBRARIES) AC_SUBST(INSTALL_MSGS) #-------------------------------------------------------------------- # Finally, substitute all of the various values into the Makefile. # You may alternatively have a special pkgIndex.tcl.in or other files # which require substituting th AC variables in. Include these here. #-------------------------------------------------------------------- AC_CONFIG_FILES([Makefile pkgIndex.tcl]) AC_OUTPUT thread3.0.1/aclocal.m40000644003604700454610000001001614726633451013151 0ustar dgp771div# # Pull in the standard Tcl autoconf macros. # If you don't have the "tclconfig" subdirectory, it is a dependent CVS # module. Either "cvs -d checkout tclconfig" right here, or # re-checkout the thread module # builtin(include,tclconfig/tcl.m4) builtin(include,naviserver.m4) # # Handle the "--with-gdbm" option for linking-in # the gdbm-based peristent store for shared arrays. # It tries to locate gdbm files in couple of standard # system directories and/or common install locations # in addition to the directory passed by the user. # In the latter case, expect all gdbm lib files and # include files located in the same directory. # AC_DEFUN(TCLTHREAD_WITH_GDBM, [ AC_ARG_WITH(gdbm, [ --with-gdbm link with optional GDBM support],\ with_gdbm=${withval}) if test x"${with_gdbm}" != x -a "${with_gdbm}" != no; then AC_MSG_CHECKING([for GNU gdbm library]) AC_CACHE_VAL(ac_cv_c_gdbm,[ if test x"${with_gdbm}" != x -a "${with_gdbm}" != "yes"; then if test -f "${with_gdbm}/gdbm.h" -a x"`ls ${with_gdbm}/libgdbm* 2>/dev/null`" != x; then ac_cv_c_gdbm=`(cd ${with_gdbm}; pwd)` gincdir=$ac_cv_c_gdbm glibdir=$ac_cv_c_gdbm AC_MSG_RESULT([found in $glibdir]) else AC_MSG_ERROR([${with_gdbm} directory doesn't contain gdbm library]) fi fi ]) if test x"${gincdir}" = x -o x"${glibdir}" = x; then for i in \ `ls -d ${exec_prefix}/lib 2>/dev/null`\ `ls -d ${prefix}/lib 2>/dev/null`\ `ls -d /usr/local/lib 2>/dev/null`\ `ls -d /usr/lib 2>/dev/null`\ `ls -d /usr/lib/x86_64-linux-gnu 2>/dev/null` ; do if test x"`ls $i/libgdbm* 2>/dev/null`" != x ; then glibdir=`(cd $i; pwd)` break fi done for i in \ `ls -d ${prefix}/include 2>/dev/null`\ `ls -d /usr/local/include 2>/dev/null`\ `ls -d /usr/include 2>/dev/null` ; do if test -f "$i/gdbm.h" ; then gincdir=`(cd $i; pwd)` break fi done if test x"$glibdir" = x -o x"$gincdir" = x ; then AC_MSG_ERROR([none found]) else AC_MSG_RESULT([found in $glibdir, includes in $gincdir]) AC_DEFINE(HAVE_GDBM) GDBM_CFLAGS="-I\"$gincdir\"" GDBM_LIBS="-L\"$glibdir\" -lgdbm" fi fi fi ]) # # Handle the "--with-lmdb" option for linking-in # the LMDB-based peristent store for shared arrays. # It tries to locate LMDB files in couple of standard # system directories and/or common install locations # in addition to the directory passed by the user. # In the latter case, expect all LMDB lib files and # include files located in the same directory. # AC_DEFUN(TCLTHREAD_WITH_LMDB, [ AC_ARG_WITH(lmdb, [ --with-lmdb link with optional LMDB support], with_lmdb=${withval}) if test x"${with_lmdb}" != "x" -a "${with_lmdb}" != no; then AC_MSG_CHECKING([for LMDB library]) AC_CACHE_VAL(ac_cv_c_lmdb,[ if test x"${with_lmdb}" != x -a "${with_lmdb}" != "yes"; then if test -f "${with_lmdb}/lmdb.h" -a x"`ls ${with_lmdb}/liblmdb* 2>/dev/null`" != x; then ac_cv_c_lmdb=`(cd ${with_lmdb}; pwd)` lincdir=$ac_cv_c_lmdb llibdir=$ac_cv_c_lmdb AC_MSG_RESULT([found in $llibdir]) else AC_MSG_ERROR([${with_lmdb} directory doesn't contain lmdb library]) fi fi ]) if test x"${lincdir}" = x -o x"${llibdir}" = x; then for i in \ `ls -d ${exec_prefix}/lib 2>/dev/null`\ `ls -d ${prefix}/lib 2>/dev/null`\ `ls -d /usr/local/lib 2>/dev/null`\ `ls -d /usr/lib 2>/dev/null`\ `ls -d /usr/lib/x86_64-linux-gnu 2>/dev/null` ; do if test x"`ls $i/liblmdb* 2>/dev/null`" != x ; then llibdir=`(cd $i; pwd)` break fi done for i in \ `ls -d ${prefix}/include 2>/dev/null`\ `ls -d /usr/local/include 2>/dev/null`\ `ls -d /usr/include 2>/dev/null` ; do if test -f "$i/lmdb.h" ; then lincdir=`(cd $i; pwd)` break fi done if test x"$llibdir" = x -o x"$lincdir" = x ; then AC_MSG_ERROR([none found]) else AC_MSG_RESULT([found in $llibdir, includes in $lincdir]) AC_DEFINE(HAVE_LMDB) LMDB_CFLAGS="-I\"$lincdir\"" LMDB_LIBS="-L\"$llibdir\" -llmdb" fi fi fi ]) # EOF thread3.0.1/README0000644003604700454610000000347214726633451012201 0ustar dgp771div WHAT IS THIS ? ============== This is the source distribution of the Tcl thread extension. You can use this extension to gain script-level access to Tcl threading capabilities. The extension can be used with Tcl cores starting from Tcl8.7 and later. Also, this extension supports, i.e. can be used as a loadable module of, AOLserver 4.x series of the highly-scalable web server from America Online. This extension is a freely available open source package. You can do virtually anything you like with it, such as modifying it, redistributing it, and selling it either in whole or in part. See the "license.terms" file in the top-level distribution directory for complete information. HOW TO COMPILE ? ================ Only Unix-like and Windows platforms are supported at the moment. Depending on your platform (Unix-like or Windows) go to the appropriate directory (unix or win) and start with the README file. Macintosh platform is supported with the Mac OS X only. The Mac OS 9 (and previous) are not supported. WHERE IS THE DOCUMENTATION ? ============================ Documentation in Unix man and standard HTML format is available in the doc/man and doc/html directories respectively. Currently, documentation is in reference-style only. The tutorial-style documentation will be provided with future releases of the extension. That is, if I ever get time to do that. Everybody is more than welcome to jump in and help with the docs. HOW TO GET SUPPORT ? ==================== The extension is maintained, enhanced, and distributed freely by the Tcl community. The home for sources and bug/patch database is on fossil: https://core.tcl-lang.org/thread Alternatively, you are always welcome to post your questions, problems and/or suggestions relating the extension (or any other Tcl issue) to news:comp.lang.tcl newsgroup. -EOF- thread3.0.1/ChangeLog0000644003604700454610000017741114726633451013100 0ustar dgp771div2016-06-03 Pietro Cerutti * doc/*: Bump version to 2.8 in docs [Tkt b35544d2c8] 2016-06-03 Pietro Cerutti * generic/threadCmd.c: Add parenthesis to bit-shift macros [Tkt 957dbe231c] 2016-05-31 Pietro Cerutti * generic/threadSvCmd.c: Implement [tsv::handlers] command [Tkt 72b8ee4c76] * doc/html/tsv.html * doc/man/tsv.n * doc/tsv.man * tests/tsv.test 2016-05-31 Pietro Cerutti * generic/threadCmd.c: Add status arg to [thread::exit] [Tkt 3407860fff] * tests/thread.test * doc/thread.man * doc/man/thread.n * doc/html/thread.html 2016-05-18 Pietro Cerutti * generic/threadSvCmd.c: Fix race condition in thread finalization routine [Tkt 3532972fff] * tests/tkt-84be1b5a73.test: Add a test for [Tkt 84be1b5a73] 2016-05-17 Pietro Cerutti * generic/threadCmd.c: Fix -async and result trace [Tkt 84be1b5a73] * doc/thread.man: Remove "id" arg from [thread::broadcast]'s manpage * doc/man/thread.n: Regenerate documentation * doc/html/thread.html 2016-05-13 Pietro Cerutti * aclocal.m4: Add support for LMDB persistent storage [Tkt 9378bb6795] * configure * configure.ac * doc/html/tsv.html * doc/man/tsv.n * doc/tsv.man * generic/psGdbm.c * generic/psLmdb.c * generic/psLmdb.h * generic/threadSvCmd.c * generic/threadSvCmd.h * tests/French.txt version * tests/store-load.tcl * tests/tsv.test * generic/tclThreadInt.h: Use spaces for indentation everywhere * generic/tclXkeylist.c * generic/threadCmd.c * generic/threadNs.c * generic/threadSpCmd.c * generic/threadSpCmd.h * generic/threadSvCmd.c 2016-04-20 Pietro Cerutti * configure, aclocal.m4: Correctly handle --without-gdbm [Tkt f8ff429a39] * doc/tsv.man: Document side-effect of [tsv::array unbind] [Tkt be135da5f9] * doc/*.(html|n): Regenerate documentation [Tkt 41922d3bb7] * generic/threadSvCmd.c: Avoid double query to persistent storage in tsv::array bind [Tkt a135697d8c] 2013-05-23 Jan Nijtmans * generic/threadSvKeylistCmd.c: Change a few internal variable * generic/threadSvListCmd.c: from type int to type size_t. * generic/threadCmd.c: Simplify determination of whether Tcl is compiled with thread support. * configure: re-generate with latest TEA. 2012-12-21 Jan Nijtmans * generic/tclThreadInt.h: Add runtime detection of Tcl_AddErrorInfo * generic/*.c: vs. Tcl_AppendObjToErrorInfo and Tcl_GetErrorLine vs. interp->errorLine. 2012-12-16 Jan Nijtmans * generic/*.c: Rename Tcl_Free -> ckfree and Tcl_Alloc -> ckalloc, which allows a debug build of Thread use the debug versions of those functions. 2012-12-13 Jan Nijtmans * generic/threadCmd.c: Tcl_Free cannot be used directly as freeProc (will break in "novem"), so use a small wrapper. 2012-11-08 Don Porter *** 2.7.0 TAGGED FOR RELEASE (thread-2-7-0) *** * README: Update for stable release. 2012-11-14 Jan Nijtmans * generic/threadCmd.c: Move back test for core threaded functionality * pkgIndex.tcl.in: from pkgIndex.tcl to threadCmd.c, so it cannot be escaped any more. 2012-11-13 Joe Mistachkin * generic/threadCmd.c: merge compileTipCheck to trunk. Additional functionality to switch off TIP 143/285 functionality for static builds. 2012-11-10 Zoran Vasiljevic * genric/threadCmd.c: fixed race condition on thread-local storage in ThreadCancel(). 2012-11-10 Zoran Vasiljevic *** Merged "thread-2-7for84+" branch *** 2012-11-08 Don Porter * configure.in: Bump to version 2.7.0 * lib/ttrace.tcl: * win/pkg.vc: 2012-09-13 Zoran Vasiljevic *** 2.7b1 TAGGED FOR RELEASE (thread-2-7-b1) *** * doc/html/tpool.html * doc/man/tpool.n * doc/tpool.man: fixed "tpool::create -idletime" description [Tcl Bug 3534442] * generic/threadSpCmd.h * generic/threadSvCmd.h: removed some unused structure members [Tcl Feature Request 3563391] 2012-09-11 Jan Nijtmans * Makefile.in: Use "::tcltest::loadTestedCommands" to make * tests/all.tcl: sure that the right Thread version is tested, * tests/thread.test: without requiring explicit version numbers 2012-08-29 Jan Nijtmans * generic/*.c: Remove all (deprecated) usages of _ANSI_ARGS_ and TCL_PARSE_PART1 * generic/threadSpCmd.c: Fix [Tcl Bug #3562640]: problem loading Thread * generic/threadSvCmd.c: in 8.5, when compiled for 8.6. * win/makefile.vc * Makefile.in 2012-07-17 Jan Nijtmans * win/makefile.vc: [Bug 3544932]: Visual studio compiler check fails 2012-07-05 Zoran Vasiljevic * generic/threadCmd.c: Fixed leaking callback data in ThreadSend() plus some minor cosmetic changes (tx to Gustaf Neumann). 2012-07-03 Zoran Vasiljevic * generic/threadPoolCmd.c: [Bugs 3534440, 3534581] fixed. Also, promoted jobId to be Tcl_WideInt (was uint). 2012-04-26 Don Porter * generic/threadSpCmd.c: Eliminate some tricky finalization problems by converting the SpBucket arrays from dynamic storage to static storage so they no longer need to be finalized. Since they have fixed size of NUMSPBUCKETS, I don't see any strong reason not to do this. 2012-04-24 Don Porter * generic/threadCmd.c: [Bug 1603234] Stop leak in [thread::transfer]. 2011-12-05 Joe Mistachkin * generic/threadCmd.c: Fix #define issue when compiling for Tcl 8.5. 2011-11-24 Jan Nijtmans * generic/tclThread.h: Only export Thread_Init(), nothing more. * generic/tclXkeylist.h * generic/threadSpCmd.h * generic/threadSvCmd.h * generic/threadSvCmd.c * generic/threadSvKeylistCmd.h * generic/threadSvListCmd.h 2011-11-20 Joe Mistachkin * generic/threadCmd.c: Correct check for current thread in the ThreadReserve function [Bug 3411244]. Correct the order for releasing the interpreter and freeing memory, see check-in [6067508840]. 2011-11-17 Joe Mistachkin * generic/threadCmd.c: Refactor ThreadEventProc to make sure all paths out of the function call Tcl_Release on the necessary Tcl interpreters. Also, call ThreadErrorProc consistently whenever the return code is not TCL_OK (i.e. do not check for it to be equal to TCL_ERROR). 2011-11-17 Joe Mistachkin * generic/threadCmd.c: The [thread::wait] command should use the TCL_CANCEL_UNWIND flag when calling Tcl_Canceled because it manages its own event processing loop. Also, if the event processing loop is terminated due to a script in progress being canceled or exceeding a runtime limit, the registered error script should be evaluated, if any. 2011-11-17 Joe Mistachkin * generic/threadCmd.c: The [thread::wait] command must cooperate with the interpreter resource limiting (TIP #143) and asynchronous script cancellation (TIP #285) functionality, when available. 2011-11-17 Joe Mistachkin * generic/threadCmd.c: For [thread::cancel], avoid creating a new Tcl_Obj when the default script cancellation result is desired. * doc/thread.man: Update all remaining versions to 2.7b1. * doc/tpool.man: * doc/tsv.man: * doc/ttrace.man: * lib/ttrace.tcl: * win/vc/pkg.vc: * win/vc/thread_win.dsp: * win/vc/makefile.vc: Stop using -debug:full as it causes an error with the MSVC10 compiler. 2011-09-12 Joe Mistachkin * generic/threadCmd.c: Add support for TIP #285 (asynchronous script cancellation) via a new [thread::cancel] command (available only for Tcl 8.6). * win/vc/makefile.vc: Correct path to root of source checkout. 2011-08-01 Don Porter * win/vc/rules.vc: Extend support to MSVC10. Thanks to Twylite. 2011-06-27 Don Porter * configure.in: Copied revisions from the "sampleextension" package * Makefile.in: to keep compatible with the latest INSTALL changes in TEA 3.9. * configure: autoconf-2.59 2010-12-08 Zoran Vasiljevic * generic/threadCmd.c: Fixed Bug #3129844 2010-11-18 Don Porter * Makefile.in: Revised the `make dist` target so that the * win/README.txt: files under thread/win/vc in CVS are copied to * win/vc/makefile.vc: thread/win in the release, where tcl/pkgs/ * win/vc/thread_win.dsp: expects to find them. * configure: autoconf-2.59 2010-10-04 Zoran Vasiljevic * generic/configure Regenrated for TEA 3.9. Bumped version string * generic/configiue.in in all relevant files to 2.6.7 and autoconf'ed. * win/vc/pkg.vc 2010-09-28 Zoran Vasiljevic * generic/threadCmd.c: Initialize tsdPtr->interp to NULL immediately after releasing the interp on thread-exit that should hopefully resolve the Tcl Bug #3026061 * generic/threadCmd.c: Removed safe-init so safe-interps should not be able to run thread commands directly. * lib/ttrace.tcl: Changed version to 2.6.7 to be in sync with main pkg. * configure.in: Bumped version to 2.6.7 and autoconf'ed. 2010-09-05 Donal K. Fellows * doc/tpool.man, doc/tsv.man: Remove spaces in titledesc declaration; doctools currently does not like it at all when generating correct nroff output. 2010-08-12 Andreas Kupries * lib/ttrace.tcl (_serializensp, _serializeproc): Fixed typos which smashed namespace name and opening brace of a script together, leading to a syntax error for 'namespace eval' and preventing the use of package Ttrace. 2010-07-25 Donal K. Fellows * lib/ttrace.tcl: [Bug 3033206]: Be careful with variables outside of procedures; Tcl's variable resolution rules can jump in if a variable is not declared, which can be at best surprising. Also rewrote the namespace serialization code to be more robust. 2010-05-31 Andreas Kupries * pkgIndex.tcl.in: Fixed procedure collisions for Thread package by inlining the load command into the ifneeded script, as is standard for most binary packages. Tweaked the procedure for Ttrace a bit, as the result of [info commands] is a list, and using ::apply when possible. A named procedure is only a fallback. 2010-05-27 Andreas Kupries * lib/ttrace.tcl: Resynchronized version number with Thread. 2010-05-26 Andreas Kupries * generic/threadSpCmd.c (ThreadMutexObjCmd, ThreadRWMutexObjCmd): [Bug 3007426]: Dropped trailing commas in enum definitions which choked the strictly C89 AIX compiler. 2010-04-01 Zoran Vasiljevic * generic/tclXkeylist.c: Removed declaration of global TclX keylist commands. 2010-03-30 Zoran Vasiljevic *** 2.6.6 TAGGED FOR RELEASE (thread-2-6-6) *** * configure: Redo for TEA 3.7 * configure.in: * generic/tclThread.h: Cosmetic changes for the inclusion * generic/threadCmd.c: in standard Tcl distribution. * generic/threadPoolCmd.c: * generic/threadSpCmd.c: * generic/threadSvCmd.c: * generic/threadSvCmd.h: 2010-03-19 Jan Nijtmans * generic/threadSpCmd.c: Silence gcc warning: dereferencing * .cvsignore: type-punned pointer will break strict-aliasing rules. * configure: Regenerated using latest TEA 2009-08-19 Zoran Vasiljevic * generic/threadPoolCmd.c: Implemented [tpool::suspend] * doc/tpool.man: and [tpool::resume] commands as per [RFE #2835615]. Also fixed [Bug #2833864]. 2009-07-22 Jan Nijtmans * generic/tclThread.h: Remove unnecessary ';'s * generic/tclXkeylist.c: Constify remaining of thread extension, * generic/tclXkeylist.h: bringing it at the same level as Tcl 8.6 * generic/threadCmd.c: * generic/threadPoolCmd.c: * generic/threadSpCmd.c: * generic/threadSvCmd.c: * generic/threadSvCmd.h: * generic/threadSvKeylistCmd.c: * generic/threadSvKeylistCmd.h: * generic/threadSvListCmd.c: 2009-07-16 Alexandre Ferrieux * generic/tclXkeylist.c: Constify Tcl_ObjGetType return values to * generic/threadSvCmd.c: get rid of const warnings; #if 0 of * generic/threadSvCmd.h: SvFinalize which is unused. 2009-05-04 Pat Thoyts * win/vc/makefile.vc: Updated the MSVC build to work with MSCV 8 * win/vc/rules.vc: and 9 on both intel and amd64 targets. * win/vc/nmakehlp.c: 2009-05-03 Alexandre Ferrieux * generic/threadSpCmd.c: Reorder things in RemoveMutex and RemoveCondv [Bugs 2511424,2511408]; fix a Put* leak in an error path of rwmutexes [Bug 2511420]. 2008-12-03 Jeff Hobbs * generic/threadSvCmd.c: Handle TIP#336 addition of API to access * generic/threadSpCmd.c: interp->errorLine 2008-11-03 Jeff Hobbs * generic/threadSvCmd.c (SvObjObjCmd): safely set interp result obj * generic/threadCmd.c (ThreadCutChannel): fix const warning (ThreadSend): safely set interp result object [Bug #1988779] 2009-10-22 Zoran Vasiljevic * generic/threadPool.c: fixed race condition when creating minworkers worker thread upfront. Failure to create one results in partial pool teardown. Fix for [Bug #2005794]. 2008-05-22 Zoran Vasiljevic * generic/threadSpCmd.h: Added one cond variable per sync bucket to wait for item deletion. * generic/threadSpCmd.c: Threads that want to delete any sync primitive now wait properly until the last thread that references the primitive detaches. Fixed (broken) reference counting of items. Fixed wrong release of an condition variable that is about to be time-waited. 2008-05-18 Zoran Vasiljevic * generic/threadPoolCmd.c: Corrected potential race condition in TpoolWorker(). 2007-06-30 Zoran Vasiljevic * generic/threadPoolCmd.c: Fixed signedness compiler warning on jobId in TpoolWaitObjCmd(). 2007-06-30 Zoran Vasiljevic * generic/threadSvKeylistCmd.c: Fixed off-by-1 error in argument parsing for SvKeylkeysObjCmd(). See [Tcl Bug #1575342]. * generic/threadPoolCmd.c: Fixed [Tcl Bug #1512225] (tpool::wait and tpool::cancel setting wrong values to passed variables) 2007-05-26 Zoran Vasiljevic * generic/threadPoolCmd.c: Fixed [tpool::post -nowait] to start one new worker thread only if there are none started. 2007-05-03 Pat Thoyts * win/vc/rules.vc: Updated the nmake build system to match * win/vc/nmakehlp.c: current 8.5. (support for non-intel build * win/vc/makefile.vc: and recent versions of msvc compiler) * win/thread.rc: Fixed line endings. 2006-12-26 Zoran Vasiljevic * generic/threadCmd.c: Fixed race condition for creating preserved threads. * generic/threadSv.c: Removed memory leak. 2006-10-07 Zoran Vasiljevic *** 2.6.5 TAGGED FOR RELEASE (thread-2-6-5) *** Main changes since the last release: ------------------------------------ Set versioning of (embedded) Ttrace package to the same revision level as the main Thread package. The Ttrace must now explicitly be loaded in every new thread created by [thread::create] command. The [package require Ttrace] automatically loads Thread package as well. NOTE: be sure to configure/make/make install because the pkgIndex.tcl loader file is modified. 2006-10-06 Zoran Vasiljevic * generic/threadPool.c: * generic/threadCmd.c: Removed Tcl_PkgRequire from the new thread initialization and just initialize the C-aspect of the extension by calling Therad_Init. This basically discards the last checkin, which was in a sense bad as it made thread creation very expensive operation. * pkgIndex.tcl.in: Added separate handling for Ttrace loading. Now, users needing Ttrace caps must "package require Ttrace" which in turn automatically calls "package require Thread". Also, each new thread created by [thread::create] must be initialized for Ttrace by calling the [package require Ttrace]. On the other hand, the "package require Thread" is only necessary to first-load the package in the startup thread. It is not necessary to call this explicitly in every thread created by the [thread::create] command as the C-code will do that automatically as the first thing. * doc/ttrace.man: Updated example usage to reflect above changes. * lib/ttrace.tcl: Spliced version numbering of the Ttrace package to the version of the Thread package because of the weirdness of the Tcl package loading mechanism. Also, the broadcast script used within the ttrace::eval now explicitly loads Ttrace package in every broadcasted thread. 2006-10-05 Zoran Vasiljevic * generic/threadPool.c: * generic/threadCmd.c: Call Tcl_PkgRequire() in the NewThread() to properly initialize the extension in any new thread. * doc/ttrace.man: Add small example of ttrace usage. * lib/ttrace.tcl: Fixed [ttrace:eval] to not to call [package require Ttrace] in the broadcast script as this is now done implicitly for all new threads. 2006-08-06 Zoran Vasiljevic *** 2.6.4 TAGGED FOR RELEASE (thread-2-6-4) *** * generic/tclXkeylist.c: Silenced various * generic/threadCmd.c compiler warnings. * generic/threadSvCmd.c: * README: Removed version information. * configure.in: Bumped to 2.6.4 version. * confiigure: Regenerated. 2006-06-04 Zoran Vasiljevic * generic/threadSvCmd.c: SvIncrObjCmd() now implicitly creates shared array and/or element and initializes it to zero if the array and/or the element were not found. * generic/tclThread.h: Removed some unusded debugging defs 2006-04-05 Jeff Hobbs * win/vc/pkg.vc (PACKAGE_VERSION): correct to 2.6.3 for MSVC make. 2006-03-28 Jeff Hobbs * generic/threadPoolCmd.c (AppExitHandler): fix teardown to destruct pool list correctly. [Bug 1427570] 2006-03-16 Zoran Vasiljevic *** 2.6.3 TAGGED FOR RELEASE (thread-2-6-3) *** * README: Bumped to 2.6.3 2006-03-15 Zoran Vasiljevic * configure.in: Changed BUILD_sample to BUILD_thread for Windows compile under MinGW. + configure: regen 2006-03-14 Zoran Vasiljevic * configure.in: Moved to 2.6.3 release * configure: regen 2006-02-09 Zoran Vasiljevic * generic/threadSpCmd.c: fixed race condition when testing constraints (mutex being locked by the caller thread) when waiting on the condition variable. Also, fixed exclusive mutex ownership and usage counting. * configure.in: uses TEA 3.5 * tclconfig: updated to TEA3.5 2006-01-28 Zoran Vasiljevic * generic/threadSpCmd.c: Revamped handling because of the deep * generic/threadSpCmd.h: race condition which resulted in * tests/thread.test: deadlocks when using exclusive mutexes. 2005-10-15 Zoran Vasiljevic * generic/threadCmd.c: channel transfer code cleans ready-to-fire events from the thread event queue prior to cutting the channel out of the interp. * tests/thread.test: allows channel transfer tests for all Unices and Windows using Tcl 8.4.10+ core. 2005-09-23 Zoran Vasiljevic * generic/threadCmd.c: ThreadDetach() sets the both source and target thread ID's for the detached channel to zero, thus signalizing the cleanup code to leave the channel in the cleanup-list when the thread who detached it exits. 2005-08-24 Zoran Vasiljevic * generic/tclXkeylist.c: made some calls static so they do not interfere for static linking with certain extensions. 2005-08-08 Zoran Vasiljevic * generic/threadSvCmd.c: fixed traversing the list of registered object types in Sv_DuplicateObj() (thx to eric.melbardis@netkitsolutions.com) 2005-07-27 Zoran Vasiljevic *** 2.6.2 TAGGED FOR RELEASE (thread-2-6-2) *** * configure: regen * unix/README: added some clarifications about usage of --with-gdbm switch * README: * configure.in: bumped version to 2.6.2 * aclocal.m4: fixed for alternate gdbm lib location as per patch request #1245204 * generic/tclThread.c: removed Thread_Unload and Thread_SafeUnload because we can't really be unloaded. * html/thread.html: regen * html/tpool.html: regen * html/tsv.html: regen * html/ttrace.html: regen * man/thread.n: regen * man/tpool.n: regen * man/tsv.n: regen * man/ttrace.n: regen 2005-07-26 Mo DeJong * Makefile.in: Remove SYSTEM_TCLSH and any code that tries to run tclsh at build time aside from running the test cases. * configure: Regen. * configure.in: Remove calls to TEA_BUILD_TCLSH and TEA_BUILD_WISH since these were removed from tcl.m4. This fixes up the build when --with-tcl indicates either a build dir or and install dir. 2005-07-25 Zoran Vasiljevic * pkgIndex.tcl.in: simplified by introducing a helper procedure, thus avoiding too much quoting. 2005-07-24 Mo DeJong * Makefile.in: Subst TCLSH_PROG as SYSTEM_TCLSH and subst BUILD_TCLSH and BUILD_TCLSH_PROG. * configure: Regen. * configure.in: Invoke TEA_BUILD_TCLSH from tcl.m4 to correctly determine BUILD_TCLSH. 2005-04-12 Zoran Vasiljevic * generic/tclThread.h: * generic/threadCmd.c: reverted some changes by the last checkin which slipped in by mistake 2005-04-09 Zoran Vasiljevic * generic/tclThread.h: * generic/threadCmd.c: added Thread_Unload and Thread_SafeUnload to be able to load into the 8.5 shell. Both calls are still no-ops. 2005-03-18 Jeff Hobbs * Makefile.in (AR): use @AR@ (TCLSH_ENV): add TCL_THREAD_LIBRARY var * pkgIndex.tcl.in: grok TCL_THREAD_LIBRARY var * configure, configure.in: update to TEA 3.2 2005-03-15 Zoran Vasiljevic * pkgIndex.tcl.in: Applied patch for Bug #1163357. Also, fixed the case when directory path contains blanks. 2005-03-05 Zoran Vasiljevic * generic/threadSvCmd.c: fixed potential access to the unlocked (and thus eventually freed) container * lib/ttrace.tcl: the overloaded [info] command now does the right thing when applied to non-existing procedures. We now transparently resolve them and then allow the [info] to operate on them. The ttrace::enable can now be called recursively. Also, fixed stript generation issues for namespaced variables containing wild escape sequences. 2005-01-03 Zoran Vasiljevic * generic/threadPoolCmd.c: fixed Tcl Bug #1095370. We were wrongly tearing down workers on idle timer expiry *below* the number of workers set by the "-minworkers" option. * lib/ttrace.tcl: added [ttrace::config] to control some runtime options. The only option it allows now is "-doepochs". This is a boolean flag turning the epoch generation off/on. Also, improved handling of XOTcl introspections in regard to namespaced objects/classes. 2005-01-03 Zoran Vasiljevic * lib/ttrace.tcl: added [ttrace::isenabled] and modified the [ttrace::addtrace] to dynamically activate the tracer if the tracing is already enabled. This way we can dynamically load tracer scripts. 2005-01-03 Zoran Vasiljevic **** RELEASE: 2.6.1 Tagged **** * aolserver.m4: * configure.in: * configure: rebuild and include conditional compilation for AOLserver which was wrongly ommited since the switch to the TEA3 build system. Also, we will now revert to .. version numbers for all releases. * generic/threadCmd.c: added new option "-head" to the [thread::send] command so scripts can be placed on the head of the thread event queue instead of the tail only. * doc: rebuild html/nroff files from doctools sources * generic/threadPoolCmd.c: * generic/threadSvCmd.h: * generic/tclThread.h: removed compat macros for 8.3 core * test/thread.test: added case for [thread::send -head] 2004-12-23 Zoran Vasiljevic **** RELEASE: 2.6 Tagged **** * tcl/cmdsrv/cmdsrv.tcl: example command server listens on loopback interface (127.0.0.1) only * README: removed stuff about (now unsupported) Tcl8.3 core * unix/README: clarified usage of the CONFIG file * win/vc: adjusted MSVC files for changes introduced by TEA3 2004-12-18 Zoran Vasiljevic **** COMPATIBILITY: Dropped support for Tcl8.3 **** * aclocal.m4: Adjusted for TEA3 * Makefile.in: * configure.in: * pkgIndex.tcl.in: * configure: Rebuild with autoconf 2.59 * tests/all.tcl: Removed extra handling for Tcl 8.3 * tests/thread.tcl: since we do not support 8.3 any more * generic/psGdbm.c: * generic/threadCmd.c: * generic/threadSvCmd.c: * doc/thread.man: Updated docs for the 2.6 release * doc/tpool.man: * doc/tsv.man: * doc/ttrace.man: 2004-11-27 Zoran Vasiljevic * generic/threadPoolCmd.c: Fixed race condition which resulted in blocking at pool creation with high -minworkers threads. This fixes the Tcl Bug #933975. 2004-11-25 Zoran Vasiljevic * tests/thread.tcl: Disabled all tests handling channel transfer for Windows ports until core is capable of handling this correctly. * generic/threadSpCmd.c: Fixed segmentation problems observed on Windows ports and related to notification of an uninitialized condition variable(s). This closes Bug #1051068 (wrongly posted under Tcl Patches at SF). * doc/thread.man: Fixed mutex/condvar code example. Thanks to Gustaf Neumann of XOTcl for the tip. 2004-10-21 Andreas Kupries * tests/thread.test: Added two tests checking the working of fileevents after a pipe channel has been transfered. The second has to fail for any core where TIP #218 is not applied, because the incoming alert is directed to the wrong thread for event processing. 2004-10-20 Zoran Vasiljevic * generic/threadCmd.c (ThreadSetResult): adjusted handling of interp result to accomodate for recent changes in Tcl core. This closes Tcl Bug# 1050490. 2004-10-19 Andreas Kupries * generic/threadSvCmd.c: Added a prototype for SvObjDispatchObjCmd. Prevented compilation of debug variant on Windows due to warning as error. * tests/thread.test: Added more tests transfering channels between threads for in-core drivers. 2004-10-18 Andreas Kupries * generic/threadCmd.c (ThreadErrorProc): Added code to explicitly initialize the field 'interp' in ThreadSendData. This was ok (NULL) for a regular build, but when build with symbols the guard pattern forced a crash in test thread-16.2. * tests/thread.test: Duplicate test id thread-16.1 renamed to thread-16.2. 2004-08-14 Zoran Vasiljevic * generic/threadPoolCmd.c: fixed broken parsing of pool handles. Pool handles are now generated in the same format as thread handles. * generic/threadCmd.c: thread handles are now cased to (void*) and sprint/sscanf calls are used to generate thread handles. This concludes the effort of correcting broken handles on 64-bit machines since the problem was actually in Tcl itself, rather than here. 2004-07-21 Zoran Vasiljevic * generic/tclThread.h: corrected namespace prefix for AOLserver 4.x or higher, since namespaced commands are now supported. * generic/threadCmd.c: allows for re-initializing of package commands for AOLserver 4.x (or higheri) interpreters. This way we assure to have correct set of commands even if nobody loaded the package on server startup. Also, thread handles returned by the package now have the form: "tid" in (yet another) attempt to rectify problems found on Cray computers. * generic/threadPoolCmd.c: adjusted handles of the pools to match ones of threads (see above). 2004-07-21 Zoran Vasiljevic * doc/*: reformatted docs and added some clarifications about mutex handling. * generic/threadCmd.c: rewritten handling of thread handles as passed to Tcl. Instead of casting Tcl_ThreadId to unsigned int which brought some problems on Cray machines, we're now generating opaque handles and match them to Tcl_ThreadId internally. NOTE: this is not supposed to be a compatibility issue since thread-handles should have been treated as opaque anyways. * generic/threadSpCmd.*: improved behaviour when destroying locked mutexes and locking the same mutex twice from the same thread. In both cases we throw Tcl error instead of coring the process or deadlocking the (naive) application. * generic/threadSvCmd.*: number of tsv buckets is now compile time constant. * lib/ttrace.tcl: Fixed error in unknown wrapper when the passed command was empty string. * tests/all.tcl * tests/thread.test: rewritten from scratch. * tests/tpool.test: * tests/ttrace.test: * tests/tsv.test: new files, currently no-ops. 2004-01-31 Zoran Vasiljevic * lib/ttrace.tcl: added unconditional "package require" call to ttrace::eval so we need not explicitly load the Ttrace package in each and every thread. Also, fixed some issues with errorInfo/errorCode handling. * pkgIndex.tcl.in: fixed Tcl Bug #918137 * doc/format.tcl: fixed inclusion of man.macros in every *.n doc file 2004-01-31 Zoran Vasiljevic * generic/threadCmd.c: fixed incorrect handling of return codes from the scripts passed to threads. We were wrongly triggering error for non-error return codes such as TCL_RETURN, TCL_BREAK, TCL_CONTINUE etc. Now we trigger error only for TCL_ERROR and return other codes (as-is) to the caller. This also fixes the Tcl Bug #884549. 2003-12-22 Zoran Vasiljevic * generic/threadSpCmd.c: added recursive and reader/writer locks and associated commands * generic/threadSpCmd.h: added new file * generic/lib/ttrace.tcl: added Ttrace package implementation * doc: added documentation for Ttrace package and synced other doc files to match the release 2.6 state. 2003-12-01 Zoran Vasiljevic * generic/threadCmd.c: removed the concept of foreign thread since it broke our async message bouncing. We still have to find the way how we should avoid broadcasting non-package threads (like for aolserver). 2003-11-27 Zoran Vasiljevic * generic/threadCmd.c: fixed mutex release in ThreadSend when refusing to send message to foreign thread. Also, clear the result of the thread::broadcast since it should not return anything to the caller, no matter the outcome of the command. 2003-11-27 Zoran Vasiljevic * generic/threadCmd.c: mark threads created by the package to distinguish them from "foreign" threads. We will forbid sending messages to those since they will probably never listen. * generic/threadSvCmd.c: corrected some typos * generic/threadSvListCmd.c: added implementation for the "tsv::lset" command * generic/threadPoolCmd.c: added optional varname argument (last arg) to the tpool::cancel 2003-11-25 Zoran Vasiljevic * doc/format.tcl: new file with a simple poor man's documentation formatter. * doc/thread.man * doc/tpool.man * doc/tsv.man: new doctools source files for building the package documentation. * Makefile.in: added support for building nroff and html files out of doctools sources found in doc directory. 2003-11-18 Zoran Vasiljevic * generic/threadCmd.c: added implementation of the thread::broadcast command. This one asynchronously sends a script to all known threads, except the caller. 2003-09-03 Zoran Vasiljevic * generic/tclXkeylist.(c|h): added keyed-list datatype implementation borrowed from the TclX package. This is now part of the shared variable command set. * generic/threadSvCmd.(c|h): modified to support persistent shared variables with plugin-architecture for different persistent store implementations. * generic/threadSvlistCmd.(c|h): modified to reflect added support for persistent shared variables. * generic/psGdbm.(c|h): added persistent store wrapper for the GNU gdbm package. * configure et al: regenerated with autoconf because of added optional comilation with GNU gdbm. Updated makefiles to process newly added files for keyed lists and persistent stores. 2003-08-27 Zoran Vasiljevic * generic/threadPoolCmd.c: after expiration of the idle timer, all idle workers exit unconditionaly. Before the change, idle threads exited after getting the first job posted. This way we were loosing work. 2003-08-26 Zoran Vasiljevic * generic/threadPoolCmd.c: fixed result list corruption in TpoolCancelObjCmd. 2003-07-27 Zoran Vasiljevic * generic/threadPoolCmd.c: added "-nowait" option to the "tpool::post" commandi. This allows the caller to post jobs to the threadpool queue without waiting for an idle thread. The implementation will start at least one worker thread if there is none available to satisfy the first request. Added "tpool::cancel" command. See docs for info. 2003-05-31 Zoran Vasiljevic * generic/threadCmd.c: fixed ListRemoveInner for the Tcl Bug #746352 * generic/threadSpCmd.c: modified Sp_Init to return a proper value for Tcl Bug #746352 2003-05-17 Zoran Vasiljevic * generic/threadCmd.c: sets the name of the new thread to "-tclthread-" when compiled for AOLserver 2003-04-29 Zoran Vasiljevic Tagged interim 2.5.2 release. * configure.in * configure: Added quick fix for autoconf issues related to $srcdir and building of the package from the top-level dir instead of unix/win subdir. Thanks to Mo DeJong for the fix. 2003-04-10 Zoran Vasiljevic * generic/threadCmd.c: removed checking of stopped flag during walk of the list of active threads. This solves some subtle thread reservation problems with threads marked to unwind on error. Also, added new "-errorstate" configuration option to set/get error state of reserved unwinding thread. 2003-04-02 Zoran Vasiljevic * generic/threadCmd.c: * generic/threadPoolCmd.c: * generic/threadSpCmd.c: * generic/threadSvCmd.c: always call registered exit callbacks with non-NULL clientData, otherwise Tcl won't invoke the registered callback. 2003-03-28 Zoran Vasiljevic * generic/threadSvList.c * generic/threadSvCmd.c: fixed some rare cases where we incorrectly deep-copied the list object having zero elements. * generic/threadCmd.c: fixed broken AOLserver 3.x compatibility mode introduced by last 4.x changes. 2003-03-17 Zoran Vasiljevic * generic/threadSvCmd.c: fixed incompatibility with Tcl 8.4.2 filepath object * generic/threadCmd.c: * aolstub.cpp: adjusted for AOLserver 4.0 2003-02-24 Zoran Vasiljevic * generic/threadCmd.c: fixed ThreadSetResult to correctly initialize all elements of the result structure. 2003-02-08 Zoran Vasiljevic * generic/threadCmd.c: fixed ListRemoveInner to correctly update global threadList ptr when the last referenced thread exits. This was not the case before and we were trashing memory leading to process exitus. 2003-01-25 Mo DeJong * generic/threadCmd.c (ThreadSendObjCmd): The thread::send command was not working under Win32 because threads that had an id that was a negative number were generating a usage error in the thread::send command. * tests/thread.test: Add test for negative number as thread id. 2003-01-22 Zoran Vasiljevic * generic/threadCmd.c: fixed reference to errorInfo when reporting error from the passed script. 2003-01-21 Mo DeJong * configure: Regenerate to include recent fixes for mingw build support in tclconfig module. 2002-12-18 Zoran Vasiljevic * README: added some AOLserver info * tcl/tpool/tpool.tcl: added missing tpool::names command 2002-12-14 Zoran Vasiljevic * doc/*: finished docs for the 2.5 release 2002-12-09 Zoran Vasiljevic * generic/threadPoolCmd.c: added tpool::names command added -exitscript for tpool::create * doc/tpool.tmml * doc/man/tpool.n * doc/html/tpool.html: added files. This is still the work in progress. 2002-12-06 Zoran Vasiljevic * configure.in * configure * Makefile.in * aolserver.m4: added support for compilation under AOLserver as loadable module. 2002-12-06 Zoran Vasiljevic * generic/threadSvCmd.c: the tsv::lock now allows for unsetting the shared array within the script argument. * generic/threadPoolCmd.c: fixed one missing mutex unlock in the ThreadRelease. * tcl/tpool/tpool.tcl: implemented missing API calls found in the C-level implementation. * tcl/phttpd/phttpd.tcl: simplified switching to Tcl-level threadpool implementation. 2002-12-04 Zoran Vasiljevic * generic/threadPoolcmd.c: rewritten to use worker threads sitting on the cond var instead of in the event loop. The poster thread still respects i.e. does not block the event loop while posting jobs. 2002-12-03 Zoran Vasiljevic * generic/tclthread.h: added SpliceIn/SpliceOut macros. Fixed to include exports from threadPoolCmd.c * generic/threadSpCmd.c: does regular namespace handling over the NS variable instead of hard-coding the "thread" prefix for mutex/cond commands. * generic/threadCmd.c: rewritten to use SpliceIn/SpliceOut macros instead of hand-fiddling with linked lists. * generic/threadPoolCmd.c: new file * Makefile.in: added threadPoolCmd.c to list of source files. 2002-11-25 Zoran Vasiljevic * tcl/phttpd/phttpd.tcl: added raw file; no thread support * tcl/cmdsrv/cmdsrv.tcl: first working version 2002-11-24 Zoran Vasiljevic * tcl/tpool/tpool.tcl: added threadpool implementation in Tcl * tcl/phttpd: added directory for later mt-enabled pico-httpd * tcl/cmdsrv: added directory for later socket command server * doc/man/thread.n * doc/thread.tmml * doc/html/thread.html: new tsv::eval, thread::attach, thread::detach * generic/threadSvCmd.h * generic/threadSvCmd.c: added tsv::eval command * generic/threadCmd.c: added thread::attach, thread::detach Also, fixed thread::preserve and thread::release to accept the thread id as the optional paramter. 2002-11-23 Zoran Vasiljevic * generic/threadCmd.c: fixed ListRemoveInner() to recognize and ignore already removed tsd thread structures. Fixed some invalid TCL_OK returns which masked serious errors. 2002-11-07 Zoran Vasiljevic * generic/threadCmd.c: fixes problem when trying to report the error from an async callback when the stderr channel is not available (wish/tclkit on windows). Thanks to Wojciech Kocjan for the correction. 2002-10-23 Zoran Vasiljevic * generic/threadCmd.c: added handling of background errors while doing an async callback. 2002-10-20 Zoran Vasiljevic * doc/html/thread.html * doc/man/thread.n * doc/thread.tmml: fixed "thread::send" command summary. It was showing the wrong position of the "-async" argument. * generic/threadSpCmd.c: adjusted mutex/cond handles to use the same format and handling as AOLserver counterparts when compiled for AOLserver support. This way one can mix and match primitives declared with ns_mutex and thread::mutex and/or ns_event and thread::cond commands. Added thread::eval command. See documentation for syntax and usage. 2002-10-15 Jeff Hobbs * configure: * configure.in: move the CFLAGS definition into TEA_ENABLE_SHARED and make it pick up the env CFLAGS at configure time. 2002-08-23 Zoran Vasiljevic * threadCmd.c: fixed potential memory corruption when releasing preserved interpreter. [Tcl bug 599290] 2002-08-19 Zoran Vasiljevic * generic/threadSvCmd.c: we now properly invalidate duped object string rep if the internal rep has been regenerated. 2002-08-18 Zoran Vasiljevic * generic/threadCmd.c: updated some comments * generic/threadSvCmd.c: * generic/threadSvListCmd.c: fixed silly mem leak where we were registering commands and object types for each new thread, resulting in unnecessary table grow. Not a memory leak per-se, therefore not found by Purify, but shows itself by observing the size of the process using the top utility. Gosh! 2002-08-03 Zoran Vasiljevic * generic/threadSvListCmd.c: corrected "tsv::lpush" to correctly make a copy of the object pushed into the list in shared array element. 2002-07-22 Mo DeJong * README: Fix typo. * doc/man/thread.n: Note that thread::join and thread::transfer are only available with Tcl 8.4. 2002-07-20 Mo DeJong * generic/threadSvCmd.c (Sv_tclEmptyStringRep, Sv_Init): Avoid linking to the tclEmptyStringRep variable defined in Tcl since this makes it very difficult to load the Thread package into an executable that has also loaded Tcl. The previous approach used a hack under Windows, we now use this same hack on all systems. [Tcl patch 584123] 2002-07-19 Zoran Vasiljevic * threadCmd.c: added some macros to simplify adding and removing result structure in and out of the corresponding lists 2002-07-18 Zoran Vasiljevic * threadCmd.c: modified thread::release to allow for optional "-wait" argument. This will result in the thread waiting until the target thread has really exited. Otherwise, the command exits immediately and target thread may exit asynchronously some time later. This is not techically needed since one can always join the exiting thread, but the join command is not available for some older Tcl versions. 2002-07-13 Zoran Vasiljevic * doc/man: * doc/html: added two directories with TMML generated files * doc/thread.tmml: fixed for the final 2.4 release * Makefile.in: updated install-doc target to look for man files under doc/man instead only under doc directory 2002-07-12 Zoran Vasiljevic * generic/threadSvCmd.s: fixed handling of string rep in shared var object duplicator 2002-07-09 Zoran Vasiljevic * README: added this file * license.terms: added this file 2002-07-05 Zoran Vasiljevic * tclconfig/tcl.m4: fixed reference to MINGW so we can compile w/o MSVC under windows. 2002-07-03 Zoran Vasiljevic * generic/threadSvCmd.c: simplified object duplicator 2002-06-17 Zoran Vasiljevic * generic/threadCmd.c: cleanup of some unused variables * generic/threadSvCmd.c: * generic/ThreadSpCmd.c: * generic/threadSvList.c: added CONST qualifiers to avoid warnings when compiling against 8.4 core. 2002-05-25 Zoran Vasiljevic * generic/threadCmd.c: added some typecasts to satisfy Windows * generic/threadSvCmd.h: added some typecasts to satisfy Windows 2002-05-04 Zoran Vasiljevic * generic/threadSvCmd.c: removed errant reference to (still not) supported shared dictionary and shared keylist datatypes. 2002-04-27 Zoran Vasiljevic * generic/threadCmd.c: fixed processing of -eventmark. We now properly wait for target thread to catch up with processing events. 2002-04-07 Zoran Vasiljevic * generic/threadCmd.c: added call to Ns_TclMarkForDelete(interp) when compiled for AOLserver support, otherwise we were leaking std channels on thread exit. 2002-04-03 Jeff Hobbs * Makefile.in: improved use of DESTDIR in install targets. Removed need for installdirs target. Broke TCLSH_PROG into TCLSH_ENV and TCLSH_PROG with TCLSH var and added comments about TCLSH_ENV. Added default shell and gdb targets. * configure: * configure.in: updated to new TEA base that: prefixes all macros with TEA_* instead of SC_*; adds TEA_PREFIX, which defaults the prefix and exec_prefix values to what Tcl used; adds TEA_SETUP_COMPILER, which handles basic compiler / support program checks and simplifies the configure.in. Turn on --enable-threads by default and do sanity checking as well. 2002-04-01 Jeff Hobbs * Makefile.in (install-lib-binaries): ensure that binary files are installed with executable bit set (use INSTALL_PROGRAM) 2002-03-28 Jeff Hobbs * configure: * configure.in: BUILD_${PACKAGE} had to be static BUILD_thread in AC_DEFINE because autoconf wasn't substituting ${PACKAGE}. 2002-03-27 Jeff Hobbs * Makefile.in (TCLSH_PROG): moved and updated env var definitions to have tclsh work from build dir. Removed TCL_EXTRA_CFLAGS, TCL_LD_FLAGS, TCL_SHLIB_LD_LIBS, TCL_DBGX, TCL_STUB_LIB_FILE, TCL_STUB_LIB_SPEC as they aren't needed (configure acquires all that info for us). TCL_LIBS is also not needed, but left in as a reference to the libs Tcl used. * configure: regen based on updated tclconfig/tcl.m4 * configure.in: moved the SHLIB_LD_LIBS magic into tclconfig/tcl.m4 and noted where users can modify (SHLIB_LD_)LIBS. 2002-03-19 Jeff Hobbs * generic/tclThread.h: * generic/threadCmd.c: added stub voodoo magic to allow building against Tcl 8.3 and still get all the 8.4+ functionality when later loaded into an 8.4+ interp. * pkgIndex.tcl.in: simplified auto-generated pkgIndex.tcl file. * tests/all.tcl: * tests/thread.test: improved to detect 8.3/8.4 pkg differences * tclconfig/tcl.m4,install-sh (new): * config/* (removed): * aclocal.m4: * configure: * configure.in: * Makefile.in: Updated build system to use tclconfig (TEA 2002) structure. 2002-03-09 Zoran Vasiljevic * generic/threadSvCmd.c: fixed memory leak when copying objects using custom object duplicator. If a duplicator was registered more than once, we were leaking memory. 2002-03-08 Zoran Vasiljevic * generic/threadCmd.c: added thread::configure -unwindonerror configuration option. See docs for usage. * doc/thread.n: added docs for thread::configure -unwindonerror 2002-03-07 Zoran Vasiljevic * generic/threadSvCmd.c: tsv::names will skip reporting shared arrays with leading dot in their names. This is turned-on only for AOLserver builds with the HIDE_DOTNAMES. For the regular Tcl builds, all arrays are reported, regardless of the name. Motivation behind this feature is to allow certain data privacy. It is not name-clash proof, though. 2002-02-12 Zoran Vasiljevic * generic/threadCmd.c: fixed thread::preserve glitch. We never actually did bump the reservation counter by a silly mistake. 2002-02-12 Zoran Vasiljevic * generic/threadCmd.c: added thread::preserve and thread::release commands. These allow for a simple reference counting when creating and/or tearing-down threads. Instead of calling thread::unwind in the target thread, one can use "thread::release id" to dispose it. This is much easier to use and it can be coupled with calls to thread::preserve to implement simple thread reservation mechanism. * doc/thread.n: added docs for thread::preserve/thread::release 2002-02-09 Zoran Vasiljevic * generic/threadCmd.c: added thread::configure interface. Currently only "-eventmark" option is supported. Allows for AOLserver builds to change the "thread::" prefix by re-defining the "NS" compile-time constant. * doc/thread.n: added docs for thread::configure 2002-02-06 Zoran Vasiljevic * generic/aolserv.cpp: (new) added for loading into the AOLserver. Still needs to fix the Makefile and friends to get it up and running. * generic/threadCmd.c: added conditional setup of the command prefix. Now, the "NS" can be used to select the command prefix for thread::* commands. 2002-01-26 David Gravereaux * generic/threadSvCmd.c: A small 'const' qualifier change to remove a warning. It's a bit more wordy now, but reads a little clearer to me. Unscambling pointer math gives me a headache and combined with a cast tends to get dangerous. * win/threadWin.c: new idea for thread::kill added. It's wrapped in an #if 0/#endif for now. I do notice that tcl.h is now typedef'ing ClientData as an 'int *'. It used to 'void *', didn't it?? The ISO/ANSI/CLEAN C style of setting a typed pointer to a void* now doesn't want to work. Maybe I do too much C++ to have noticed this before... 2002-01-23 Zoran Vasiljevic * generic/threadCmd.c: fixed address of the target interpreter when doing the callback async script processing. All messages went to the main interpreter instead of the selected interpreter, causing process to hung when posting callbacks to more that one interp at the same time. (thanks Jean-Luc Fontaine for the tip) 2002-01-20 Zoran Vasiljevic * generic/threadCmd.c: fixed multiple async reporting of error events (thanks Jean-Luc Fontaine for the tip) 2002-01-02 Zoran Vasiljevic * generic/threadSvListCmd.* (new): added for the new implementation of the thread-shared-variable (tsv) interface. * generic/threadSvCmd.c: now uses shared Tcl objects instead of strings for storing data in shared arrays. This improves performance on large shared data structures. Added new tsv::* syntax, per request. This replaces older thread::sv_* interface. Older commands are still present but will be removed as soon we hit the 3.0 version. * generic/threadCmd.c: revamped to support asynchronous backfiring of scripts so we can vwait on the results of thread processing. This also corrected the bug #464340. Affected command is thread::send. * doc/thread.n: added docs for all thread::* and tsv::* commands. This fixes #416850 bug report. The html/tmml files are still out of date. * configure: built with autoconf 2.52 * config/config.guess (new): needed for the new configure * config/config.sub (new): needed for the new configure * Makefile.in: added lines for new generic/threadSvListCmd.c * configure.in: moving to 2.4 version. * unix/threadUnix.c: removed traces of ThreadKill. It is still not clear wether we should implement this functionality or not. * win/threadWin.c: see above. * pkgIndex.tcl.in: fixed to correctly handle version for different Tcl core versions. 2001-09-05 David Gravereaux * generic/*: * win/threadWin.c (new): updated for a new threadWin.c and finished replacing use of thread.h with tclThread.h. threadWin.c is an experiment to add a 'thread::kill' command. Not done yet. * win/vc/thread.rc (removed): * win/thread.rc (new): moved it up a directory. 2001-09-04 David Gravereaux * generic/thread.h (deleted): * generic/tclThread.h (new): * generic/threadCmd.c: decided to change the name of 'thread.h' to 'tclThread.h', per request. * generic/thread.h: * generic/threadCmd.c: Re-added original implimentation of [thread::exit]. for `emergency use only`. You have been warned ;) * configure.in: * configure: * win/vc/thread.dsp: * win/vc/pkg.vc: Upped version numbers to 2.3 and 2.1.3 because I just cut a release. 2001-09-04 David Gravereaux -=[ Official 2.2 Tagged and cut. ]=- 2001-05-27 David Gravereaux * tests/thread.test: fixed small typo in comments. 2001-08-03 Jeff Hobbs * Makefile.in: corrected handling of VERSION * generic/threadCmd.c: * generic/thread.h: added Thread_SafeInit * win/vc/makefile.vc: added -DBUILD_thread to cflags. 2001-05-27 David Gravereaux * configure: * configure.in: * Makefile.in: Added package versions to the compile flags. [bug #421246] 2001-04-28 David Gravereaux * generic/threadCmd.c (NewThread): removed the previous addition of Tcl_FinalizeThread. Tcl_ExitThread calls it anyways (my mistake). The resource leak was in the core. See -> http://sourceforge.net/tracker/?func=detail&atid=110894&aid=419683&group_id=10894 for the fix. That patch is pending approval. To acheive the same behavior of emptying the event loop the way thread::wait used to work, use the following: set T [thread::create {thread::wait; update}] thread::send -async $T thread::unwind * generic/thread.h: * win/vc/makefile.vc: * win/vc/thread.rc: * win/vc/pkg.vc (new): Moved version numbers from the header file. It isn't an export API or anything. Moved version numbers to the build files. I'll modify configure.in and makefile.in a little later. 2001-04-26 David Gravereaux * config/* (new): old site-wide config directory re-added. * generic/threadCmd.c (ThreadEventProc): ThreadErrorProc now supported in asyncronous sends when Tcl_Eval returns other than TCL_OK. Errors were silently ignored prior to this. Bug #219324 ==== INTERFACE CHANGE ==== * generic/threadCmd.c: * generic/thread.h: thread::exit renamed to thread::unwind. The name of 'exit' is misleading. An exit implies an unconditional return. But there are conditions. 'unwind' describes with more clarity what's happening to the prior thread::wait. For example: # parent thread set T [thread::create {source worker.tcl}] .... thread::send -async $T doStuff .... thread::send -async $T doStuff .... thread::send -async $T thread::unwind # worker.tcl proc init {} {#do initialization} proc cleanup {} {#do cleanup} proc doStuff {} {#the work} init thread::wait cleanup When worker.tcl is sourced, the execution stops at thread::wait and the event loop is entered. When thread::unwind is sent to the worker, thread::wait falls-out and cleanup is called. The condition for thread::unwind to cause an exit is determined by the script. If thread::wait was the last Tcl command in the script, yes the thread will exit. But if thread::wait is not the last, the execution of the script is just continued. Hence, the name change to clarify this fact. Package version has not been changed. There hasn't been an official release of 2.2, so it stays. * doc/thread.n: * tests/thread.test: Replaced thread::exit with thread::unwind and documented the change and clarified the subtleties. * win/vc/makefile.vc: * win/vc/thread.dsp: Changed NODEBUG macro to be DEBUG instead. Double negatives give me a headache. DEBUG=1 makes more sense to me than NODEBUG=0. Not that I didn't think you wouldn't have disagreed it was confusing, no? * win/vc/config.vc: Added a reminder to edit before using. * win/vc/thread.rc: Added authors and removed the Ajuba branding. 2001-04-25 David Gravereaux * generic/threadCmd.c (ThreadWait)(NewThread): Removed the event loop sinking which was probably done because Tcl_FinalizeThread was missing from NewThread(). Now the event loop is cleaned by Tcl_FinalizeThread and ThreadWait doesn't manipulate events that don't belong to it. Bug #418689 and #418693 * generic/threadCmd.c (Thread_Init): logic fix in a version check for determining the 8.3 package subset. 2000-11-02 David Gravereaux * generic/threadCmd.c (NewThread): Added logic to test for a working Tcl_Init() based on the core version at runtime and ignore its failure in versions 8.3.[1,2] and 8.4a1. [BUG: 5301] 2000-10-26 David Gravereaux * generic/thread.h: * win/vc/config.vc: * win/vc/makefile.vc: * win/vc/thread.dsp: upped version numbers to 2.2 along with adding a new macro (THREAD_VERSION_SUBSET83) defining the version when loaded into an 8.3 core. Which happens to be "2.1.1" at this time. * generic/threadCmd.c (Thread_Init): Added logic to allow setting the package version at runtime to "2.2" when compiled against 8.4 and loaded into 8.4. When compiled against 8.4, yet loaded into 8.3, thread::join and thread::transfer are not added to the interp and the package version is set to "2.1.1" instead from the single binary. [ie. multiple interfaces in one binary] When compiled against 8.3, thread::join and thread::transfer are non-existant and the package version is always "2.1.1" to maintain a consistent interface in all combinations (as per discussions with Don Porter). 2000-10-16 Zoran Vasiljevic * generic/threadSvCmd.c ThreadSvUnsetObjCmd(): deadlocked. Forgot to release shared-array lock which resulted in deadlock after first successful unset of the variable. 2000-08-29 David Gravereaux * generic/threadCmd.c (NewThread): Tcl_Init return value wasn't being verified. Added a check and failure logic to fall-out. [Bug: 5301] 2000-08-28 David Gravereaux * generic/threadCmds.c (Thread_Init): Added logic to enable thread::join and thread::transfer when loaded into an 8.4+ core. We don't want a seg fault when the Stubs tables don't match for the functions that don't exist in an 8.3 core. 2000-08-23 Brent Welch * configure.in: * win/vc/makefile.vc: Changed to version 2.1 * generic/threadCmds.c: Made the code that uses new Tcl 8.4 APIs conditional using #ifdef. Tested with 8.3.2 * Applied thread-2-1 tag for use with tclhttpd bundled release. 2000-08-21 David Gravereaux * win/vc/makefile.vc: * win/vc/thread.rc: added version numbers to filename to follow Tcl standards. * doc/thread.tmml(new): Initial TMML document. 2000-08-20 David Gravereaux * win/vc/config.vc: * win/vc/makefile.vc: * win/vc/README.txt: * win/vc/thread.dsp: A near top down rewrite that adds four more build configurations. See README.TXT for the details. * win/vc/.cvsignore: A few more glob patterns added to match the new build directories. 2000-08-09 David Gravereaux * win/vc/thread.rc: swapped "Scriptics Corp" for "Ajuba Solutions" * win/vc/config.vc: * win/vc/makefile.vc: cleaned-up old cruft. Added new files from Zoran's patches. made swapping to MSDev 6.0 easier. Removed the '!if $(_NMAKE_VER) > 162' test for 2 reasons. 1) batchmode inference rules are valid since MSDev 5.0 and the core can't be built with less. So don't bother testing. 2) nmake.exe that comes with MSDev 6.0 has a bug with the meaning of that macro and MS decided to use a string instead breaking the integer comparison test. Also added vcvars32.bat to a new setup rule and got config.vc much smaller. * win/vc/thread.dsp: Added new files from Zoran's patch. * win/.cvsignore(deleted): * win/vc/.cvsignore(added): moved file to help keep a cleaner build environment. * generic/threadSvCmd.c: Added some additional casting of Tcl_GetHashValue to prevent compiler warnings. * generic/threadCmd.c(ThreadWait): Removed the event loop sinking after the "while(..) Tcl_DoOneEvent();" because this extension is only responsible for it's own events in the event loop. Any other extension that's queueing events must be responsible for it's own cleanup and should be aware of when the interp (ie. this thread) is going away when we fall-out to Tcl_DeleteInterp from the Tcl_Eval in NewThread(). If other extensions (like Tk) don't become aware, then they need to add a Tcl_CallWhenDeleted handler. 2000-07-14 Zoran Vasiljevic * generic/threadCmd.c: improved thread::exit behaviour now does a better job of draining the event loop before exit. may have some wishes open, though - see ThreadWait(). * generic/threadSpCmd.c, generic/threadSvCmd.c: added some comments in function headers. docs/tests for above still pending. 2000-07-03 Zoran Vasiljevic Summary of changes: * generic/threadSpCmd.c: new file with implementation of "thread::mutex" and "thread::cond" commands. Documentation and tests are still pending. * generic/threadSvCmd.c: new file with implementation of "thread::sv_*" family of commands modeled after AOLserver nsv_* ones. Documentation and tests are still pending. * Makefile.in: fixed for the two above * doc/thread.html * doc/thread.n: added 'thread::exists' docs * generic/thread.h added declarations for new commands (above) * generic/threadCmd.c: Added "thread::exists" command. Moved most of internal functions in threadCmd.c to statics, except the Thread*ObjCmd(). Changed behaviour of "thread::exit". It now simply flips the bit to signal thread stuck in thread::wait to gracefuly exit. Consequence: command now does not trigger error on thread exit. Also, thread event queue is now properly cleared. ThreadWait() and ThreadStop() are newly added to support this. Also the ThreadSpecificData has one more integer: "stopped" Replaced ref's to obsolete Tcl_GlobalEval() with Tcl_EvalEx(). Fixed broken 'thread::create -joinable script'; was missing initialization of script variable Added calls to initialize new commands in threadSpCmd.c and threadSvCmd.c files. 2000-05-18 Brent Welch * Restored Andreas' changes for transferring sockets. 2000-05-16 Brent Welch * Temprarily rolled back Andreas' changes so I can fix up the 2.0 release (configure and Make). Also need to apply a 2.0 tag. 2000-05-09 Andreas Kupries * tests/thread.test: Removed dependency on aclocals.m4. Using a real temporary file now, as created by a call to tcltest::makeFile. Updated test 6.3 to use the correct length information. 2000-05-04 Andreas Kupries * Overall changes: (1) Added joinable threads. (2) Added transfer of channels between threads. * generic/threadCmd.c: Added functions Thread_Join and ThreadJoinObjCmd. Extended function ThreadCreateObjCmd to handle a -joinable flag. Fixed bug in Thread_Create, the argument 'stacksize' was not used. Removed declaration of ThreadObjCmd, which was not used anywhere else in the code. Added functions Thread_Transfer, ThreadTransferEventProc and ThreadTransferObjCmd. Extended behaviour of ThreadDeleteEvent and ThreadExitProc to deal with the new class of events. Changed usage of ckfree to the more canonical Tcl_Free. Same for ckalloc and Tcl_Alloc. * Makefile.in: Fixed bug with regard to the installation of documentation. * doc/thread.*: Added documentation of create -joinable, thread::join and thread::transfer. * tests/thread.test: Added tests for joining of threads and moving channels between threads. 2000-04-19 Brent Welch * win/vc/config.rc, Makefile.vc: Fixes from David Gravereaux 2000-04-18 Brent Welch * Makefile.in: Fixes for make install 2000-04-17 Brent Welch * generic/threadCmd.c Added Tcl_CreateThreadType and TCL_RETURN_THREAD_TYPE macros for declaring the NewThread callback proc. 2000-04-11 Brent Welch * Picked up minor changes from David Gravereaux * for compilation on windows with his alternate project files. 2000-04-10 Brent Welch * Moved all the configure.in, Makefile.in etc. up to the top level out * of the unix (and win) subdirectories. These are now shared. * If you are using CVS, you'll want to get the "config" module into * this directory, or do the checkout of thread again so the config * module is brought in. You should have a "config" subdirectory of * your main thread workspace directory. 2000-04-09 Brent Welch * Updated to compile against 8.3.1 export thread APIs * Added Windows makefiles 2000-03-27 Brent Welch (proxy for Andreas Kupries) * tests/all.tcl: Added this file * tests/thread.test: fixed to use tcltest * doc/thread.n: Added this file as clone of thread.html # doc/thread.html: fixed typo thread3.0.1/manifest.uuid0000644003604700454610000000010114731033512013765 0ustar dgp771div630906017b990453a5404fbb06f332f6a185f07d3f1c5f3b960dbe98aebd60bf thread3.0.1/license.terms0000644003604700454610000000426714726633451014022 0ustar dgp771divThis software is copyrighted by the Regents of the University of California, Sun Microsystems, Inc., Scriptics Corporation, and other parties. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. GOVERNMENT USE: If you are acquiring this software on behalf of the U.S. government, the Government shall have only "Restricted Rights" in the software and related documentation as defined in the Federal Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are acquiring the software on behalf of the Department of Defense, the software shall be classified as "Commercial Computer Software" and the Government shall have only "Restricted Rights" as defined in Clause 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the authors grant the U.S. Government and others acting in its behalf permission to use and distribute the software in accordance with the terms specified in this license.