# 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: psbyname.tcl,v 1.20 2006/04/04 12:25:46 jfontain Exp $


# note: this module is very similar to the psbyuser module, so any code changes should be synchronized


package provide psbyname [lindex {$Revision: 1.20 $} 1]
package require network 1
package require stooop 4.1
namespace import stooop::*
package require switched
if {[catch {package require Thread 2.5}]} {
    namespace eval psbyname {variable threads 0}
} else {                                                                                  ;# load thread worker class implementation
    package require threads 1
    namespace eval psbyname {variable threads 1}
}
package require linetask 1
package require hashes
package require miscellaneous


namespace eval psbyname {

    array set data {
        updates 0
        0,label name 0,type dictionary 0,message {process name or filename of the executable} 1,anchor left
        1,label %CPU 1,type real 1,message {processor usage in percent}
        2,label %memory 2,type real 2,message {memory usage in percent}
        3,label RSS 3,type integer 3,message {real memory size in kilobytes}
        4,label files 4,type integer 4,message {number of opened files}
        persistent 1 64Bits 1
        switches {--all 0 -C 0 --daemon 0 --files 0 -i 1 -p 1 --proc 1 -r 1 --remote 1 -u 1 --users 1}
    }
    set file [open psbyname.htm]
    set data(helpText) [read $file]
    close $file
    unset file

    proc initialize {optionsName} {
        upvar 1 $optionsName options
        variable remote
        variable data
        variable threads                                                                     ;# whether threads package is available
        variable show
        variable userOrPID
        variable dataDirectory

        set show(all) [info exists options(--all)]
        set show(files) [info exists options(--files)]
        if {$show(files)} {
            set data(views) [list [list visibleColumns [list 0 1 2 3 4] sort [list 1 decreasing]]]
        } else {
            set data(views) [list [list visibleColumns [list 0 1 2 3] sort [list 1 decreasing]]]
        }
        set string {}; catch {set string $options(-u)}; catch {set string $options(--users)}                    ;# favor long option
        foreach item [split $string ,] {                                      ;# comma separated list of PIDs / users (may be empty)
            set userOrPID($item) {}                                  ;# note: user or PID array non existence signifies no filtering
        }
        set dataDirectory /proc; catch {set dataDirectory $options(--proc)}              ;# note: use /compat/linux/proc for FreeBSD
        catch {set locator $options(-r)}; catch {set locator $options(--remote)}                                ;# favor long option
        if {![info exists locator]} {                                                                            ;# local monitoring
            set currentDirectory [pwd]; cd $dataDirectory; cd $currentDirectory                      ;# catch potential errore early
            set data(pollTimes) [list 20 10 30 60 120 300 600]
            return
        }
        set data(pollTimes) [list 30 20 60 120 300 600]                                  ;# poll less often when remotely monitoring
        append data(1,message) { (approximated)}                                                                  ;# as in ps module
        # for remote monitoring, decode protocol, remote user and host
        foreach {remote(protocol) remote(user) remote(host)} [network::parseRemoteLocator $locator] {}
        set remote(rsh) [string equal $remote(protocol) rsh]
        set data(identifier) psbyname($remote(host))
        # important: pack data in a single line
        set remote(command,processes) \
"exec 2>/dev/null
cd $dataDirectory"
        append remote(command,processes) {
pids=`echo [0-9]*`
echo -n pid {$$} pids {$pids} meminfo {`fgrep MemTotal: meminfo`}
for id in $pids; do
    echo -n '' $id,status {`fgrep Uid: $id/status`} $id,stat {`cat $id/stat`} $id,statm {`cat $id/statm`}}
        if {$show(files)} {
            append remote(command,processes)\
                { "$id,nfd "; cd $id/fd \&\& set -- * \&\& cd ../.. \&\& echo -n $# || echo -n '?';}
        }
        append remote(command,processes) {
done
echo -n '' uptime {`cat uptime`}}
        # important: pack data in a single line using special control separator characters:
        set remote(command,users) {cat /etc/passwd | tr '\n' '\v'}
        set remote(pattern) %c
        if {$::tcl_platform(platform) eq "unix"} {
            if {$remote(rsh)} {                              ;# command is included in line task command, so it must include pattern
                set remote(pattern) "rsh -n -l $remote(user) $remote(host) {$remote(pattern)}"
            } else {
                set command ssh
                if {[info exists options(-C)]} {append command { -C}}                                            ;# data compression
                if {[info exists options(-i)]} {append command " -i \"$options(-i)\""}                              ;# identity file
                if {[info exists options(-p)]} {append command " -p $options(-p)"}                                           ;# port
                append command " -T -l $remote(user) $remote(host)"
            }
        } else {                                                                                                          ;# windows
            if {$remote(rsh)} {error {use -r(--remote) ssh://session syntax (see help)}}
            set remote(rsh) 0
            set command "plink -ssh -batch -T $remote(host)"       ;# note: host must be a putty session and pageant must be running
        }
        if {$remote(rsh)} {
            set access r                                                                            ;# writing to pipe is not needed
        } else {
            set access r+                                                                                     ;# bi-directional pipe
            # terminate remote command output by a newline so that the buffered stream flushes it through the pipe as soon as the
            # remote data becomes available:
            append remote(pattern) {; echo}
        }
        set remote(task) [new lineTask -callback psbyname::read -begin 0 -access $access -translation lf -threaded $threads]
        if {!$remote(rsh)} {
            switched::configure $remote(task) -command $command
        }
        if {![info exists options(--daemon)] && !$remote(rsh)} {             ;# for ssh, detect errors early when not in daemon mode
            lineTask::begin $remote(task)
        }                                                       ;# note: for rsh, shell and command need be restarted at each update
        set remote(updateUserNames) 0
        set remote(busy) 0
    }

    proc update {} {
        variable remote
        static command
        static updateUserNames

        if {[info exists remote]} {
            if {$remote(busy)} return                                               ;# core invocation while waiting for remote data
            if {![info exists command] || ($updateUserNames ^ $remote(updateUserNames))} {      ;# generate command only when needed
                set updateUserNames $remote(updateUserNames)
                if {$updateUserNames} {
                    regsub %c $remote(pattern) $remote(command,users) command
                } else {
                    regsub %c $remote(pattern) $remote(command,processes) command
                }
                if {$remote(rsh)} {
                    switched::configure $remote(task) -command $command
                }
            }
            set remote(busy) 1
            if {[lineTask::end $remote(task)]} {                                                           ;# rsh or ssh daemon mode
                lineTask::begin $remote(task)                       ;# note: for rsh, shell and command are restarted here each time
            }
            if {!$remote(rsh)} {
                lineTask::write $remote(task) $command                     ;# start data retrieval by sending command to remote side
            }
        } else localUpdate
    }

    proc localUpdate {} {                                                                            ;# retrieve data from localhost
        variable uid                                                                                     ;# pid to uid mapping cache
        variable show
        variable userOrPID
        variable userName
        variable dataDirectory

        set currentDirectory [pwd]
        cd $dataDirectory
        set file [open meminfo]
        while {[gets $file line] >= 0} {
            if {[scan $line {MemTotal: %u} array(meminfo)] > 0} break
        }
        close $file
        set file [open uptime]
        set array(uptime) [lindex [gets $file] 0]                                                                      ;# in seconds
        close $file
        set unknown 0
        set pids {}
        foreach pid [glob -nocomplain {[1-9]*}] {
            if {![info exists uid($pid)]} {                                                              ;# if uid is not yet cached
                if {[catch {set file [open $pid/status]}]} continue                       ;# no valid data for this process, abandon
                while {[gets $file line] >= 0} {
                    if {[scan $line {Uid: %u} uid($pid)] > 0} break                                             ;# save uid in cache
                }
                close $file
                if {![info exists uid($pid)]} continue         ;# process may have disappeared while we were reading its status file
            }
            if {[info exists userOrPID] && ![info exists userName($uid($pid))]} {set unknown 1}      ;# there seems to be a new user
            set uids($uid($pid)) {}
            lappend pids $pid
        }
        if {$unknown} {                                                                  ;# note: always happens at the first update
            localUpdateUserNames
            updateUserIdentifiers [array names uids]
        }
        set array(pids) {}
        foreach pid $pids {
            set current($pid) {}                                                                       ;# remember process existence
            if {[info exists userOrPID]} {                                                                        ;# filtering users
                set user $uid($pid); catch {set user $userName($user)}                               ;# user defaults to its user ID
                if {![info exists userOrPID($user)] && ![info exists userOrPID($uid($pid))]} continue        ;# not a monitored user
            }
            if {$show(files)} {
                if {[file executable $pid/fd]} {
                    set files [llength [glob -nocomplain $pid/fd/*]]
                } else {
                    set files ?
                }
            }
            if {[catch {set file [open $pid/stat]}]} {                                               ;# process may have disappeared
                unset current($pid)
                continue
            }
            set length [gets $file processLine]
            set clock [expr {[clock clicks -milliseconds] / 1000.0}]                   ;# immediately store current clock in seconds
            close $file
            if {$length == 0} {                                                                              ;# account for failures
                unset current($pid)
                continue
            }
            if {[catch {set file [open $pid/statm]}]} {                                              ;# process may have disappeared
                unset current($pid)
                continue
            }
            set length [gets $file memoryLine]
            close $file
            if {$length == 0} {                                                                              ;# account for failures
                unset current($pid)
                continue
            }
            set array($pid,clock) $clock
            set array($pid,stat) $processLine
            set array($pid,statm) $memoryLine
            if {$show(files)} {set array($pid,nfd) $files}
            lappend array(pids) $pid
        }
        cd $currentDirectory
        foreach pid [array names uid] {                                                    ;# cleanup data for disappeared processes
            if {![info exists current($pid)]} {unset uid($pid)}
        }
        process array
    }

    proc remoteUpdate {line} {
        variable remote
        variable uid                                                                                     ;# pid to uid mapping cache
        variable userOrPID
        variable userName

        # catch bad data (such as generated by some output in the user .profile, for example):
        if {[catch {array set array $line}]} {              ;# note: in case of an unexpected event, task insures that line is empty
            flashMessage "invalid data: [string range $line 0 80]..."
        }
        if {\
            ![info exists array(meminfo)] || ([scan $array(meminfo) {MemTotal: %u} total] != 1) ||\
            ![info exists array(uptime)] || ([llength $array(uptime)] == 0)\
        } {                                                                                                 ;# invalid returned data
            set array(meminfo) 0; set array(uptime) [list 0 0]; set array(pids) {}             ;# consider data corrupted as a whole
        } else {
            set array(meminfo) $total
            set array(uptime) [lindex $array(uptime) 0]                                     ;# expected (example): "1611.47 1549.09"
            set clock [expr {[clock clicks -milliseconds] / 1000.0}]                   ;# used for all remote processes calculations
            set unknown 0
            set pids {}
            foreach pid $array(pids) {
                if {$pid == $array(pid)} continue                                            ;# ignore data retrieval process itself
                if {![info exists uid($pid)] && ([scan $array($pid,status) {Uid: %u} uid($pid)] != 1)} continue
                if {[info exists userOrPID] && ![info exists userName($uid($pid))]} {set unknown 1}  ;# there seems to be a new user
                set uids($uid($pid)) {}
                lappend pids $pid
            }
            if {$unknown} {                                                              ;# note: always happens at the first update
                set remote(updateUserNames) 1
                set remote(busy) 0
                update                                                                             ;# retrieve and update user names
                vwait ::psbyname::remote(updateUserNames)
                updateUserIdentifiers [array names uids]
            }
            set array(pids) {}
            foreach pid $pids {
                set current($pid) {}                                                                   ;# remember process existence
                if {[info exists userOrPID]} {                                                                    ;# filtering users
                    set user $uid($pid); catch {set user $userName($user)}                           ;# user defaults to its user ID
                    if {![info exists userOrPID($user)] && ![info exists userOrPID($uid($pid))]} continue    ;# not a monitored user
                }
                if {$array($pid,stat) eq ""} {                                                       ;# process may have disappeared
                    unset current($pid)
                    continue
                }
                set array($pid,clock) $clock
                lappend array(pids) $pid
            }
        }
        foreach pid [array names uid] {                                                    ;# cleanup data for disappeared processes
            if {![info exists current($pid)]} {unset uid($pid)}
        }
        process array
    }

    proc process {arrayName} {                                                          ;# process processes data and update display
        upvar 1 $arrayName array
        variable last
        variable data
        variable show

        set uptime $array(uptime)
        set total $array(meminfo)
        foreach pid $array(pids) {
            # scan fields (see ps.tcl)
            scan $array($pid,stat)\
                {%*d (%[^)]) %*s %*d %*d %*d %*d %*d %*u %*u %*u %*u %*u %u %u %*d %*d %*d %*d %*d %*d %lu %*u %d}\
                comm utime stime starttime RSS                 ;# utime, stime and starttime (64 bits) are in hundredths of a second
            if {[catch {set row [hash64::string $comm 1]} message]} {                                             ;# repeatable mode
                flashMessage "warning: duplicate row ($comm) removed: $message"                               ;# should be very rare
                continue
            }
            set clock $array($pid,clock)
            if {![info exists count($row)]} {
                set data($row,0) $comm
                set files($row) ?
                set count($row) 0
                set unshared($row) 0
                set shared($row) 0
            }
            unset -nocomplain value
            if {[info exists last($pid,utime)]} {
                # calculate CPU utilization during last poll period, force integer calculations since values can wrap around using
                # 32 bit integers subtractions (valid on 32 and 64 bit Tcl platforms)
                set value [expr {\
                    ((($utime - $last($pid,utime)) & 0xFFFFFFFF) + (($stime - $last($pid,stime)) & 0xFFFFFFFF)) /\
                    ($clock - $last($pid,clock))}\
                ]
            } else {                                                                                  ;# first occurence of this pid
                set delta [expr {$uptime - ($starttime / 100.0)}]
                if {$delta > 0} {
                    set value [expr {($utime + $stime) / $delta}]                         ;# use average value since process started
                }
            }
            if {[info exists value]} {
                if {[info exists cpu($row)]} {
                    set cpu($row) [expr {$cpu($row) + $value}]
                } else {
                    set cpu($row) $value
                }
            }
            unset -nocomplain value
            scan $array($pid,statm) {%*u %*u %u %*u %*u %*u %*u} value                                               ;# shared pages
            incr unshared($row) [expr {$RSS - $value}]                                                       ;# in pages of 4 kBytes
            incr shared($row) $value
            if {$show(files)} {
                if {$files($row) eq "?"} {                                                                                   ;# void
                    set files($row) $array($pid,nfd)                                                          ;# could still be void
                } else {
                    catch {incr files($row) $array($pid,nfd)}                                           ;# added value could be void
                }
            }
            array set last [list $pid,clock $clock $pid,utime $utime $pid,stime $stime]
            set current($pid) {}
            incr count($row)
        }
        foreach name [array names data *,0] {
            set row [lindex [split $name ,] 0]
            if {[info exists count($row)] && ($show(all) || ($unshared($row) > 0) || ($shared($row) > 0))} {
                if {[info exists cpu($row)]} {set data($row,1) [format %.1f $cpu($row)]} else {set data($row,1) ?}
                set data($row,3) [expr {($unshared($row) + round(double($shared($row)) / $count($row))) * 4}]  ;# a page is 4 kBytes
                set data($row,2) [format %.1f [expr {100.0 * $data($row,3) / $total}]]
                set data($row,4) $files($row)
            } else {                                                                                  ;# cleanup disappeared entries
                array unset data $row,\[0-9\]*
            }
        }
        foreach name [array names last *,clock] {                                                     ;# cleanup disappeared entries
            set pid [lindex [split $name ,] 0]
            if {![info exists current($pid)]} {array unset last $pid,*}
        }
        incr data(updates)
    }

    proc read {line} {                                       ;# read remote data now that it is available and possibly handle errors
        variable remote

        switch $lineTask::($remote(task),event) {
            end {
                # either valid data availability as rsh connection was closed, or connection broken for ssh, in which case remote
                # shell command will be attempted to be restarted at next update
            }
            error {                                                                              ;# some communication error occured
                set message "error on remote data: $lineTask::($remote(task),error)"
            }
            timeout {                                                                         ;# remote host did not respond in time
                set message "timeout on remote host: $remote(host)"
            }
        }
        if {[info exists message]} {
            flashMessage $message
        }
        if {$remote(updateUserNames)} {
            updateUserNames [split [string trimright $line \v] \v]
            set remote(updateUserNames) 0                                                                                    ;# done
        } else {
            remoteUpdate $line                                                                   ;# note: line is a serialized array
        }
        set remote(busy) 0
    }

    proc localUpdateUserNames {} {
        if {![catch {set file [open /etc/passwd]}]} {
            updateUserNames [split [::read -nonewline $file] \n]
            close $file
        }
    }

    proc updateUserNames {lines} {
        variable userName                                                                         ;# user identifier to name mapping

        unset -nocomplain userName
        foreach line $lines {
            set list [split $line :]
            set userName([lindex $list 2]) [lindex $list 0]
        }
    }

    proc updateUserIdentifiers {list} {
        variable userName

        foreach uid $list {
            if {![info exists userName($uid)]} {
                set userName($uid) $uid           ;# keep using its identifier from now on (avoids updating user names continuously)
            }
        }
    }

}
