set cgiframe_version 0.08
#===============================================================================
# Packages
#===============================================================================
# Achtung: Nicht-Standard-Paket bgexec erforderlich!
if {[catch {package require ncgi
package require html
package require bgexec} rc]} {
# absoluter Notausstieg - keine CGI-Header!
puts "Content-Type: text/plain\n\nFehler `$rc` - Abbruch!"
exit 1
}
#===============================================================================
# Unterprozeduren
#===============================================================================
proc progSpec path {
# Pfadangabe IMMER als relativ zu CGI-BIN betrachten, Dirs aber erlauben!
# 0.08: möglicherweise kommt Drivespec nicht zuerst; da aber bei file join
# die zuletzt angegebene DriveSpec 'gewinnt' (wenn sie am Anfang steht),
# wäre durch ../../d:/.. die Prüfung kompromittierbar! daher schon am
# Anfang mögliche ./\\ wegnehmen!
set path [string trimleft $path {./\\}]
if {[string range $path 1 1] == ":"} {
set path [string replace $path 0 1]
}
set path [string trimleft $path {./\\}]
# Fehler (bis v0.04): durch Folgendes wird ein Backslash auch in den
# KommandoPARAMETERN in einen Slash umgesetzt!!
#set path [file join [pwd] $path]; # Voraussetzung: PWD liefert CGI-BIN!
set path "[file join [pwd] [lindex $path 0]] [lrange $path 1 end]"
# ggf. hier Fehler melden!
set prog [lindex $path 0]
if {![file isfile $prog] || ![file executable $prog]} {
abort Die Datei<br><b>$prog</b><br> existiert nicht oder ist nicht \
ausführbar oder kein Programm!
}
return $path
}
#-------------------------------------------------------------------------------
proc header {} {
# CGI- und HTML-Header
# Möglichen Aufruf von der Kommandozeile zu Debuggingzwecken berücksichtigen
if {[info exists ::env(REQUEST_URI)]} {
ncgi::reset
ncgi::parse
ncgi::header ; # schon hier, falls Fehlermeldungen früh generiert werden!
}
# CSS hier einfügen oder einbinden
::html::headTag {style type="text/css">
<!--
-->
</style}
puts [html::head [ncgi::value title]]
puts [html::bodyTag]
set ::cgiframe_filter [ncgi::value filter]
set ::cgiframe_timeout [ncgi::value timeout]
if {![string is integer $::cgiframe_timeout] || \
[string equal $::cgiframe_timeout ""]} {
set ::cgiframe_timeout 1200000; # 20 Minuten * 60 Sekunden * 1000
}
}
#-------------------------------------------------------------------------------
proc footer {} {
set goback {}
catch {set goback $::env(HTTP_REFERER)}
if {![string equal $goback ""]} {
# besser mittels JS-Button siehe hamue_user.tcl (self.location)
puts "<br><div align=\"right\"><a href=\"$goback\">Zurück</a></div>"
}
puts "<p><hr><small>[ncgi::value title] © 2002-2004 MH, HMK \
<br> \
Diese HTML-Seite wurde generiert am \
[clock format [clock seconds] -format {%d.%m.%Y um %H:%M:%S Uhr}] \
vom Script [info script], Version $::cgiframe_version</small>"
puts [html::end]
}
#-------------------------------------------------------------------------------
proc abort {args} {
puts "<p><table align=\"center\" bgcolor=\"silver\" border=\"3\" width=\"50%\" \
cellpadding=\"5\" frame=\"box\" height=\"30%\">
<tr>
<th align=\"left\" height=\"10%\">Fehler:</th>
</tr>
<tr>
<td align=\"left\" valign=\"top\">[join $args]</td>
</tr>
<tr>
<td align=\"right\" height=\"10%\">(Das Skript wurde vorzeitig beendet)</th>
</tr>
</table><p>"
footer
exit 1
}
#-------------------------------------------------------------------------------
proc outLine data {
# später hier alles wunderschön als Tabelle formatieren...
# oder nur wechselnde Hintergründe je Zeile
# evtl. sollte PID hier zV stehen (für gemischte Ausgaben versch. Procs)
if {[string equal $::cgiframe_filter ""] || \
[string match -nocase $::cgiframe_filter $data]} {
incr ::lineCount
# puts [encoding convertfrom cp437 $data]; # bis v0.6
puts $data
}
}
#===============================================================================
# Main
#===============================================================================
header
set exec [ncgi::value exec]
set exec [progSpec $exec]
# was ist mit STDERR? Offenbar gibt der tclhttpd stderr standardmässig zurück...
fconfigure stdout -buffering line -blocking 0
fconfigure stdin -buffering line -blocking 0
set lineCount 0
puts "Ergebnis von <b>$exec</b>"
if {[string equal $::cgiframe_filter ""]} {
puts ":<hr>"
} else {
puts " (Filter='$::cgiframe_filter'):<hr>"
}
puts <b><pre> ; # später Tabellenbeginn etc.
set processHandle [bgExec $exec outLine pCount]
fconfigure $processHandle -encoding cp437; # v0.7; entspr. BgExec-Option fehlt!
# Abbruch nicht von bgExec behandeln lassen, da dort (noch) kein Process-Kill!
after $::cgiframe_timeout {
# set pCount 0; # eigentlich nicht nötig, da Ausstieg via Abort!
# Prozess beenden:
catch {exec -- [auto_execok pv.exe] -k -f -i [pid $processHandle]} rc;
# Callback zurücksetzen - keine Fehler mehr ausgeben! Nützt nichts:
# proc outLine data {}
catch {close $processHandle} rc; # bewirkt Broken_Pipe zumindest bei Tcl-
# Progs, die dadurch natürlich auch enden. Was ist mit anderen Progs? testen!
puts </b></pre><p>
puts "$::lineCount Zeile(n) Output"
abort Abbruch durch Timeout! <p> ($rc)
}
vwait pCount
puts </b></pre><p>
puts "$::lineCount Zeile(n) Output"
footer
exit 0
#*******************************************************************************