# -*- tcl -*-
# Sub-servers, subservient
#
# Copyright (c) 2003 by Andreas Kupries <[email protected]>
# ####################################################################
# Code for the easy creation of sub-processes from a testsuite to
# perform some actions on behalf of it. General sub-processes and
# socket servers, the latter are based on "microserv.tcl".
# ####################################################################
namespace eval ::subserv {
set here [file dirname [info script]] ; # To find muserv.tcl
variable mPipe ; set mPipe ""
variable mCtrl ; set mCtrol 0
variable mLog ; set mLog ""
}
package require log ; # tracing | tcllib
# ####################################################################
# API
# ::subserv::pipe --
#
# Start a generic sub-process, controllable by its pipe.
proc ::subserv::pipe {pathToScriptFile} {
log::log debug "subserv | pipe | $pathToScriptFile"
global tcl_platform
switch -exact $tcl_platform(platform) {
windows {return [open "|\"[info nameofexecutable]\" $pathToScriptFile" r+]}
default {return [open "|[info nameofexecutable] $pathToScriptFile" r+]}
}
}
# ::subserv::exec --
#
# Start a generic sub-process, via plain exec, asked to listen on port for
# control commands.
proc ::subserv::exec {pathToScriptFile port} {
global tcl_platform
exec [info nameofexecutable] $pathToScriptFile $port &
after 100
return [socket localhost $port]
}
# ::subserv::muserv --
#
# Create a micro server which can be run later.
proc ::subserv::muserv {pathToScriptFile ctrlport port responses} {
variable here
log::log debug "subserv | muserv | $pathToScriptFile $ctrlport $port [llength $responses]"
catch {file delete -force $pathToScriptFile}
set script [open $pathToScriptFile w]
puts $script ""
puts $script "# -----------------------------------------------"
puts $script "# Configuration of \"musub.tcl\""
puts $script ""
puts $script [list set logfile $pathToScriptFile.log]
puts $script [list set port $port]
puts $script [list set responses $responses]
puts $script [list set ctrlport $ctrlport]
puts $script ""
puts $script "# -----------------------------------------------"
puts $script ""
set in [open [file join $here microserv.tcl] r]
fcopy $in $script
close $in
set in [open [file join $here musub.tcl] r]
fcopy $in $script
close $in
close $script
return
}
# ::subserv::muservSpawn --
#
# Create a micro server and run it immediately.
proc ::subserv::muservSpawn {pathToScriptFile port responses} {
variable mPipe
variable mCtrl
log::log debug "subserv | muserv spawn | $pathToScriptFile $port [llength $responses]"
set lsock [socket -server ::subserv::muservCtrl 0]
set ctrlport [lindex [fconfigure $lsock -sockname] end]
log::log debug "subserv | muserv spawn | control on $ctrlport"
muserv $pathToScriptFile $ctrlport $port $responses
muservStop
set mPipe [pipe $pathToScriptFile]
log::log debug "subserv | muserv spawn | pipe on $mPipe"
vwait ::subserv::mCtrl
set port [gets $mCtrl]
log::log debug "subserv | muserv spawn | server waiting on $port"
return $port
}
proc ::subserv::muservCtrl {thesock addr port} {
variable mCtrl $thesock
log::log debug "subserv | muserv ctrl | $addr $port :: $mCtrl"
return
}
# ::subserv::muservStop --
#
# Stop a running micro server
proc ::subserv::muservStop {} {
variable mPipe
variable mCtrl
if {$mPipe == {}} {return}
log::log debug "subserv | muserv stop | request"
catch {close $mCtrl}
catch {close $mPipe}
log::log debug "subserv | muserv stop | done"
after 100 ; # sleep for a 1/10th second to make sure it is gone.
set mPipe {}
return
}
# ::subserv::muservLog --
#
# Get a trace from the micro server
proc ::subserv::muservLog {} {
variable mCtrl
log::log debug "subserv | muserv log | request"
puts $mCtrl ::muserv::gettrace
flush $mCtrl
log::log debug "subserv | muserv log | collect"
set res [list]
while {1} {
gets $mCtrl line
log::log debug "subserv | muserv log | __ $line"
if {[string equal __EOTrace__ $line]} {break}
lappend res $line
}
log::log debug "subserv | muserv log | ok"
return $res
}
