----
'''Calling arbitrary commandline tools via cgi, showing output as html-page'''

'''''Example'''''

Showing the system-log-events happened the last 24 hours from ''server'':

 http://host/cgi-bin/prog/cgiframe.tcl?exec=eldump.exe -s server -l system -l -M -L -A 24 -Q

'''Attention!'''

   * Be sure to protect the directory this proc is called from (.tclaccess) to not open an security leak!
   * Move the proc in it's own subdirectory; only commands from within these directory are accessible via CGIFRAME
----

 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] &copy 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

 #*******************************************************************************