# copyright (C) 1997-2006 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu

# $Id: apachex.tcl,v 2.20 2006/01/28 19:16:59 jfontain Exp $


package provide apachex [lindex {$Revision: 2.20 $} 1]
package require miscellaneous 1
package require apacheutilities 1

namespace eval apachex {

    array set data {
        updates 0
        0,label server 0,type integer 0,message {server number}
        1,label generation 1,type integer 1,message {generation (available after version 1.3.6)}
        2,label process 2,type dictionary 2,message {operating system process identifier}
        3,label accesses 3,type integer 3,message {number of accesses for this connection / this child / this slot}
        4,label mode 4,type ascii 4,message\
            "_(waiting), Starting, Reading, W(sending), Keepalive,\nD(DNS lookup), Logging, G(finishing), .(no process)"
        5,label {CPU usage} 5,type real 5,message {CPU usage in seconds}
        6,label {request age} 6,type dictionary\
            6,message {time since beginning of most recent request, in d(ays), h(ours), m(inutes) and s(econds)}
        7,label {request time} 7,type integer 7,message {milliseconds required to process most recent request}
        8,label {connection traffic} 8,type real 8,message {kilobytes transferred for this connection}
        9,label {child traffic} 9,type real 9,message {megabytes transferred for this child}
        10,label {slot traffic} 10,type real 10,message {total megabytes transferred for this slot}
        11,label client 11,type integer 11,message {client network address} 11,anchor left
        12,label {virtual host} 12,type integer 12,message {server virtual host} 12,anchor left
        13,label request 13,type integer 13,message {HTTP request} 13,anchor left
        14,label traffic 14,type real 14,message {kilobytes per second being transferred for this slot}
        pollTimes {10 5 20 30 60 120 300}
        views {
            {visibleColumns {0 1 2 3 4 5} sort {0 increasing}}
            {visibleColumns {0 6 7 8 9 10 14} sort {0 increasing}}
            {visibleColumns {0 11 12 13} sort {0 increasing}}
        }
        persistent 1
        switches {-r 1 --remote 1 --proxyhost 1 --proxyport 1}
    }
    set file [open apachex.htm]
    set data(helpText) [read $file]                                                           ;# initialize HTML help data from file
    close $file
    unset file

    proc initialize {optionsName} {
        upvar 1 $optionsName options
        variable url
        variable data
        variable host

        set url [::apache::url options host apachex]
        set data(identifier) apachex($host)
        ::apache::configure options
        ::http::geturl $url -validate 1                                    ;# test server so an error is generated if not responding
    }

    proc update {} {
        variable url
        variable transaction
        variable data

        if {[info exists transaction]} return                                                                                ;# busy
        if {[catch {set transaction [::http::geturl $url -command ::apachex::completed]} message]} {
            flashMessage "error: $message"
            cleanupRows voidArray
            incr data(updates)                                                                                   ;# show void values
        }
    }

    proc completed {token} {
        variable data
        variable last
        variable transaction
        variable host

        set valid [expr {[::http::ncode $token] == 200}]                                      ;# sole HTTP code for good transaction
        if {$valid} {
            set body [set ${token}(body)]                                ;# keep first table rows except the 1st row (column titles)
            set lines [string range $body [expr {[string first </tr> $body] + 5}] [expr {[string first </table> $body] - 1}]]
            regsub -all \n [string trim $lines] {} lines                                         ;# carriage returns must be ignored
            regsub -all \t $lines { } lines                         ;# replace all tabs by spaces as tabs will be used as separators
            regsub {^<tr[^>]*>} $lines {} lines                                                  ;# remove extreme table row markers
            regsub {</tr>$} $lines {} lines
            # table row markers are row separators (use tab character as replacement)
            regsub -all {</tr> *<tr[^>]*>} $lines \t lines
            set separator {<td[^>]*>}                                                      ;# table cell markers are cell separators
            foreach line [split $lines \t] {
                regsub ^$separator $line {} line                                                      ;# remove leftmost cell marker
                regsub -all $separator $line \t line                                               ;# use tab character as separator
                set column 0
                foreach cell [split $line \t] {
                    regsub -all {<[^>]+>} $cell {} cell                                    ;# remove all remaining (formatting) tags
                    if {$column == 0} {
                        set generation ?
                        scan $cell %u-%u row generation                  ;# generation is set here in apache version 1.3.6 and above
                        set current($row) {}                                        ;# keep track of current rows for latter cleanup
                        set data($row,$column) $row
                        set data($row,[incr column]) $generation
                    } else {
                        set data($row,$column) $cell
                    }
                    incr column
                }
                set data($row,6) [formattedTime $data($row,6)]
                if {[info exists last($row,10)]} {
                    set data($row,14) [expr {($data($row,10) - $last($row,10)) * 1000.0}]            ;# dynamic traffic in kilobytes
                } else {
                    set data($row,14) ?
                }
                set last($row,10) $data($row,10)                         ;# save megabytes for slot for dynamic traffic calculations
            }
        } else {
            if {[::http::ncode $token] == 404} {
                flashMessage "error: no server status on $host"
            } else {
                flashMessage "error: [::http::code $token]"
            }
        }
        ::http::cleanup $token                                                                              ;# free transaction data
        cleanupRows current
        unset transaction                                                                              ;# ready for next transaction
        incr data(updates)
    }

    proc cleanupRows {currentNames} {
        upvar 1 $currentNames current
        variable data
        variable last

        foreach {name row} [array get data *,0] {                                                      ;# cleanup vanished rows data
            if {[info exists current($row)]} continue
            for {set column 0} {$column <= 14} {incr column} {
                unset data($row,$column)
            }
            catch {unset last($row,10)}                                                          ;# previous poll data may not exist
        }
    }

}
