# 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: pci.tcl,v 1.44 2006/01/28 19:16:59 jfontain Exp $


# This module displays information about all PCI buses on a host system and all
# devices connected to them.
# It is also fully documented in order to serve as a reference for all remote
# capable modules that communicate to a remote machine via a remote capable
# shell program.
# This implementation tries to be as reliable as possible, while trying to
# never hang or crash the core and therefore other loaded modules, by using Tcl
# channel events or Tcl threads if there are available on the client system.
# Comments purely related to the way to implement a module do not appear, as
# they are already available in the random module source code and the complete
# HTML documentation.


package provide pci [lindex {$Revision: 1.44 $} 1]
# load package used for handling module remote arguments
package require network 1
# load object oriented package needed by task class
package require stooop 4.1
namespace import stooop::*
# load class that implement configuration by switches
package require switched
if {[catch {package require Thread 2.5}]} {
    namespace eval pci {variable threads 0}
} else {                              ;# load thread worker class implementation
    package require threads 1
    namespace eval pci {variable threads 1}
}
# load class that transparently handles communication with a data pipe, and that
# can use threads if available, or asynchronous event handling otherwise
package require linetask 1


namespace eval pci {

    array set data {
        updates 0
        0,label bus 0,type dictionary 0,message {bus number}
        1,label device 1,type dictionary 1,message {device (slot) number}
        2,label function 2,type integer 2,message {function number}
        3,label type 3,type ascii 3,message {device type}
        4,label description 4,type ascii 4,message {device description}
            4,anchor left
        indexColumns {0 1 2}
        pollTimes {60 10 20 30 120 300 600}
        persistent 1
        switches {-C 0 --daemon 0 -i 1 -p 1 --path 1 -r 1 --remote 1}
    }
    # options (see pci HTML documentation for detailed information):
    #   --path: the directory where the lspci command resides
    #   -r (--remote): the remote host specification in URL format

    set file [open pci.htm]
    set data(helpText) [::read $file]     ;# initialize HTML help data from file
    close $file
    unset file

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

        set path /sbin                         ;# default path for lspci command
        catch {set path $options(--path)}            ;# may be overriden by user
        set path [file join $path lspci]
        catch {set locator $options(-r)}
        catch {set locator $options(--remote)}              ;# favor long option
        if {![info exists locator]} {                              ;# local host
            # detect errors early by attempting immediate data retrieval
            exec $path                     ;# a fatal error would be caught here
            set local(command) $path
            return                                           ;# local monitoring
        }
        # 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]
        # include the host name appear in the module identifier
        set data(identifier) pci($remote(host))
        # important: pack data in a single line using special control
        # separator characters (chosen after checking that they never are
        # included in expected remote data), and redirect error output to make
        # sure error messages are retrieved when using ssh
        set remote(command) "$path 2>&1 | tr '\\n' '\\v'"
        if {[string equal $::tcl_platform(platform) unix]} {        ;# UNIX type
            if {$remote(rsh)} {                                           ;# rsh
                # does not support disabling pseudo terminal allocation so
                # command must be launched each time in a separate session
                set command\
                    "rsh -n -l $remote(user) $remote(host) {$remote(command)}"
            } else {                                                      ;# ssh
                # ssh supports permanent connections (without pseudo terminal
                # allocation)
                set command ssh
                if {[info exists options(-C)]} {             ;# data compression
                    append command { -C}
                }
                if {[info exists options(-i)]} {                ;# identity file
                    append command " -i \"$options(-i)\""
                }
                if {[info exists options(-p)]} {
                    append command " -p $options(-p)"                    ;# port
                }
                append command " -T -l $remote(user) $remote(host) 2>@stdout"
                # note: redirect standard error to pipe output in order to be
                # able to detect remote errors
            }
        } else {                                                      ;# windows
            if {$remote(rsh)} {
                error {use -r(--remote) ssh://session syntax (see help)}
            }
            # use the excellent putty software suite, but only in ssh mode since
            # only that mode is supported in non interactive sesssions according
            # to the putty package documentation
            set remote(rsh) 0
            # note: host must be a putty session and pageant must be running
            set command "plink -ssh -batch -T $remote(host) 2>@stdout"
        }
        if {$remote(rsh)} {                                               ;# rsh
            set access r                        ;# writing to pipe is not needed
        } else {                                                          ;# ssh
            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(command) {; echo}
        }
        # create the task object used for all remote communications, using
        # read/write access as command is written to the pipe and result read
        # from the pipe, define the callback procedure invoked when the command
        # result becomes available (note: use new line character (linefeed) as
        # end of line since communicating with UNIX type OS)
        set remote(task) [new lineTask -command $command -callback pci::read\
            -begin 0 -access $access -translation lf -threaded $threads\
        ]        ;# note: use never hanging threaded implementation if available
        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(busy) 0                         ;# get ready for running mode
    }

    proc update {} {                         ;# periodically invoked by the core
        variable remote
        variable local

        if {[info exists remote]} {                               ;# remote host
            if {$remote(busy)} {
                return          ;# core invocation while waiting for remote data
            }
            set remote(busy) 1                   ;# obviously busy at this point
            if {[lineTask::end $remote(task)]} {       ;# rsh or ssh daemon mode
                # note: for rsh, shell and command are restarted here each time
                lineTask::begin $remote(task)
            }
            if {!$remote(rsh)} {                                          ;# ssh
                # start data retrieval by sending command to remote side
                lineTask::write $remote(task) $remote(command)
            }
        } elseif {[catch {set result [exec $local(command)]} message]} {
            # immediate retrieval failure on local host
            flashMessage "lspci error: $message"
        } else {
            process [split $result \n]
        }
    }

    proc process {lines} {          ;# process PCI data lines and update display
        variable data

        set expression\
            {^([[:xdigit:]]+):([[:xdigit:]]+)\.(\d)+\s([^:]*):\s(.*)$}
        foreach line $lines {
            if {![regexp\
                $expression $line dummy bus device function type description\
            ]} continue             ;# happens when lines contain error messages
            # generate unique 32 unsigned integer from bus, device (5 bits) and
            # function (3 bits) (from /usr/include/linux/pci.h)
            set row [format %u\
                [expr {("0x$bus" << 8) | ("0x$device" << 3) | $function}]\
            ]
            # fill or update row
            set data($row,0) $bus
            set data($row,1) $device
            set data($row,2) $function
            set data($row,3) $type
            set data($row,4) $description
            set current($row) {}                  ;# remember data for this poll
        }
        foreach name [array names data *,0] {     ;# cleanup disappeared entries
            set row [lindex [split $name ,] 0]
            if {![info exists current($row)]} {array unset data $row,\[0-9\]*}
        }
        if {![info exists current] && ([string length [lindex $lines 0]] > 0)} {
            # There generally should be some data, so report errors when there
            # seems to be invalid data, while ignoring empty lines, which may
            # be the result of error messages coming via ssh.
            # Note: when remotely monitoring, rsh and ssh behave differently in
            # case of errors. In rsh case, error is detected in the read{}
            # procedure when the communication pipe is closed, as is done at
            # every poll. In ssh case, the communication pipe is never closed,
            # so problems must be detected by looking at the actual returned
            # data, which, when invalid, likely contains an error message, and
            # is processed here.
            # Only report the first line, in order to warn the user, but not
            # clog the message and trace displays
            set message "invalid data: [lindex $lines 0]"
            if {[llength $lines] > 1} {
                append message "..." ;# show that there was more data to display
            }
            flashMessage $message
        }
        incr data(updates)
    }

    # read remote data now that it is available and possibly handle errors
    proc read {line} {
        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)"
            }
        }
        # unpack list while removing extra last separator without copying to a
        # variable for better performance, as data could be big
        # note: in case of an unexpected event, task insures that line is empty
        if {[info exists message]} {           ;# report unexpected event if any
            flashMessage $message
        }
        process [split [string trimright $line \v] \v]
        set remote(busy) 0            ;# ready for next data retrieval operation
    }

}
