# copyright (C) 1997-2001 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

set rcsId {$Id: snmp.tcl,v 2.4 2001/01/27 15:08:19 jfontain Exp $}


package provide snmp [lindex {$Revision: 2.4 $} 1]
if {[lsearch -exact $auto_path /usr/lib]<0} {                         ;# in case Tcl/Tk is somewhere else than in the /usr hierarchy
    lappend auto_path /usr/lib
}
package require Tnm 2.1.10

proc listRemovedDuplicates {list} {
    set return {}
    foreach element $list {
        if {[lsearch -exact $return $element]<0} {
            lappend return $element
        }
    }
    return $return
}

namespace eval snmp {

    variable nextRow 0

    array set data {
        updates 0
        switches {
            -a 1 --address 1 --community 1 --context 1 --delay 1 -i 1 --identifiers 1 --mibs 1 --port 1 --password 1 --retries 1
            -t 1 --table 1 --timeout 1 --title 1 --trace 0 --trim 1 --user 1 --version 1 --window 1
        }
        pollTimes {10 5 20 30 60 120 300}
    }
    set file [open snmp.htm]
    set data(helpText) [read $file]                                                           ;# initialize HTML help data from file
    close $file

    proc reportError {identifier message} {
        if {[string length $identifier]>0} {
            set text "mib: [mib file $identifier]\n"
        }
        append text $message
        error $text
    }

    proc initialize {optionsName} {
        upvar $optionsName options
        variable data
        variable session
        variable trace

        catch {set trace $options(--trace)}
        if {[info exists options(--mibs)]} {                                               ;# comma separated list of MIB file names
            foreach file [split $options(--mibs) ,] {
                if {[catch {mib load $file} message]} {
                    reportError {} $message
                }
            }
        }
        catch {set table $options(-t)}
        catch {set table $options(--table)}                                                                     ;# favor long option
        set string {}
        catch {set string $options(-i)}
        catch {set string $options(--identifiers)}                                                              ;# favor long option
        set trim {}
        catch {set trim $options(--trim)}
        if {[info exists table]} {
            processTableIdentifiers $table $string $trim
        } else {
            if {[string length $string]==0} {
                reportError {} {table and/or list of identifiers must be specified}
            }
            processIdentifiers $string $trim
        }
        set arguments {}
        catch {set arguments [list -address $options(-a)]}
        catch {set arguments [list -address $options(--address)]}                                               ;# favor long option
        foreach switch {community context delay port password retries timeout window} {
            catch "lappend arguments -$switch $options(--$switch)"
        }
        if {[info exists options(--version)]} {                                                     ;# default is 1 (SNMP version 1)
            switch $options(--version) {
                1 {}
                2C {lappend arguments -version SNMPv2C}
                2U {lappend arguments -version SNMPv2U}
                default {
                    reportError {} {version must be 1, 2C or 2U}
                }
            }
        }
        set session [eval snmp session $arguments]
        if {[info exists options(--title)]} {
            set address [$session cget -address]
            switch $options(--title) {
                a {set data(identifier) "snmp($address)"}
                t {set data(identifier) "snmp($table)"}
                at {set data(identifier) "snmp($address,$table)"}
                ta {set data(identifier) "snmp($table,$address)"}
                default {
                    reportError {} {--title option must be a combination of the 'a' and 't' letters}
                }
            }
        }
    }

    proc validateIdentifier {name {exact 1}} {                          ;# report an error if identifier is not part of a loaded MIB
        if {$exact} {
            set invalid [catch {mib -exact syntax $name} message]
        } else {
            set invalid [catch {mib syntax $name} message]
        }
        if {$invalid} {
            reportError {} $message
        }
    }

    proc processIdentifiers {string trim} {
        # string format is identifier,identifier,...,identifier,,identifier,identifier,... with , to separate columns and ,, tables
        variable data
        variable requestIdentifiers
        variable indexColumns
        variable delta

        regsub -all ,, $string | string
        foreach list [split $string |] {
            set identifiers {}
            foreach identifier [listRemovedDuplicates [split $list ,]] {
                validateIdentifier $identifier 0                            ;# no strict lookup since identifier can be instantiated
                if {[llength [mib index $identifier]]>0} {
                    reportError $identifier "$identifier is a table: use the -t (--table) switch"
                }
                if {[string equal [mib access $identifier] not-accessible]} {                               ;# object may be a group
                    set parent $identifier
                    set invalid 1
                    foreach identifier [mib successor $parent] {                                 ;# lookup immediate successors only
                        if {![string equal [mib access $identifier] not-accessible]} {                 ;# ignore tables, groups, ...
                            lappend identifiers $identifier
                            set invalid 0
                        }
                    }
                    if {$invalid} {
                        reportError $parent "$parent contains no accessible immediate successors"
                    }
                } else {
                    lappend identifiers $identifier
                }
            }
            lappend views $identifiers
        }
        set requestIdentifiers {}
        # use an empty hidden column as index since there is only a single row
        array set data {0,label {} 0,type ascii 0,message {} 0,0 {}}
        set nextColumn 1
        foreach list $views {
            set columns {}
            foreach identifier $list {
                set index [lsearch -exact $requestIdentifiers $identifier]                      ;# index in request identifiers list
                if {$index<0} {                                                                                   ;# not yet in list
                    set index [llength $requestIdentifiers]
                    if {[regexp {\.\d+$} $identifier]} {                                                             ;# instanciated
                        lappend requestIdentifiers $identifier
                    } else {
                        lappend requestIdentifiers $identifier.0                     ;# eventually complete with instance identifier
                    }
                }
                if {[catch {set column $columnIndex($index)}]} {              ;# identifiers thus columns may be duplicated in views
                    set column $nextColumn
                    set columnIndex($index) $column
                    incr nextColumn
                }
                lappend indexColumns($index) $column                                      ;# there can be identical columns in views
                regsub ^$trim $identifier {} data($column,label)            ;# eventually trim string from left side of column title
                # no strict lookup since identifier can be instantiated
                set data($column,type) [identifierType $identifier delta($index) 0]
                set data($column,message) [identifierMessage $identifier $delta($index)]
                if {![regexp {^(integer|real)$} $data($column,type)]} {                           ;# display numeric values centered
                    set data($column,anchor) left                                                       ;# and others left justified
                }
                lappend columns $column
            }
            lappend viewsColumns $columns
        }
        foreach columns $viewsColumns {
            lappend data(views) [list visibleColumns $columns swap 1]       ;# use a swapped display since data table has only 1 row
        }
    }

    proc processTableIdentifiers {table string trim} {
        # string format is identifier,identifier,...,identifier,,identifier,identifier,... with , to separate columns and ,, tables
        variable data
        variable requestIdentifiers
        variable requestLength
        variable indexLength
        variable indexColumns
        variable firstIdentifier
        variable numberOfColumns
        variable delta

        validateIdentifier $table
        set indices [mib -exact index $table]
        set index 0                                   ;# initialize a few things since these identifiers must be part of the request
        foreach identifier $indices {
            set indexColumns($index) {}
            identifierType $identifier delta($index)
            incr index
        }
        set indexLength $index
        set entry [mib -exact successor $table]
        if {[llength $entry]>1} {
            reportError $table "$table has several successors: please report case to jfontain@free.fr"
        }
        if {[string length $string]==0} {                                                                     ;# display all columns
            set identifiers {}
            foreach identifier [mib -exact successor $entry] {                                ;# columns are the successors of entry
                if {[lsearch -exact $identifiers $identifier]>=0} continue                            ;# already in identifiers list
                lappend identifiers $identifier
            }
            set views [list $identifiers]
        } else {                                                ;# generate list of views, a view being a list of column identifiers
            regsub -all ,, $string | string
            foreach list [split $string |] {
                set identifiers [listRemovedDuplicates [split $list ,]]
                if {$indexLength==1} {                          ;# make sure single index column object is placed first in all views
                    set identifier [lindex $indices 0]                                                    ;# index column identifier
                    set index [lsearch -exact $identifiers $identifier]
                    if {$index<0} {                                                 ;# index identifier not in view: insert it first
                        set identifiers [concat $identifier $identifiers]
                    } elseif {$index>0} {                                 ;# index identifier is in view but not first: reorder view
                        set identifiers [concat $identifier [lreplace $identifiers $index $index]]
                    }                                                                                 ;# else already ideally placed
                }
                lappend views $identifiers
            }
            foreach identifier [eval concat $views] {                                           ;# must be columns of the same table
                validateIdentifier $identifier
                if {![string equal $entry [mib -exact parent $identifier]]&&([lsearch -exact $indices $identifier]<0)} {
                    reportError $identifier "$identifier is not a column of table $table"
                }
            }
        }
        set requestIdentifiers $indices                                                    ;# required to generate unique row number
        set firstIdentifier [mib oid [lindex $requestIdentifiers 0]]
        if {$indexLength>1} {                                                                           ;# multiple column index, so
            set data(0,label) {}      ;# include a row number column so that, for example, different views can be identically sorted
            set data(0,type) integer
            set data(0,message) {row creation order}
            set nextColumn 1
        } else {                                             ;# single column index: the user should have included it in his view(s)
            set nextColumn 0
        }
        foreach list $views {
            if {$indexLength>1} {
                set columns 0                                                      ;# creation order column is always included first
            } else {
                set columns {}
            }
            foreach identifier $list {
                set index [lsearch -exact $requestIdentifiers $identifier]                      ;# index in request identifiers list
                if {$index<0} {                                                                                   ;# not yet in list
                    set index [llength $requestIdentifiers]
                    lappend requestIdentifiers $identifier
                }
                if {[catch {set column $columnIndex($index)}]} {              ;# identifiers thus columns may be duplicated in views
                    set column $nextColumn
                    set columnIndex($index) $column
                    incr nextColumn
                }
                lappend indexColumns($index) $column                                      ;# there can be identical columns in views
                regsub ^$trim $identifier {} data($column,label)            ;# eventually trim string from left side of column title
                set data($column,type) [identifierType $identifier delta($index)]
                set data($column,message) [identifierMessage $identifier $delta($index)]
                if {![regexp {^(integer|real)$} $data($column,type)]} {                           ;# display numeric values centered
                    set data($column,anchor) left                                                       ;# and others left justified
                }
                lappend columns $column
            }
            lappend viewsColumns $columns
        }
        set numberOfColumns $column
        set requestLength [expr {[llength $requestIdentifiers]+1}]                                        ;# including system uptime
        if {[llength $viewsColumns]>1} {                                                                  ;# more than a single view
            foreach columns $viewsColumns {
                lappend data(views) [list visibleColumns $columns sort {0 increasing}]
            }
        }
    }

    proc identifierType {name counterName {exact 1}} {                                                 ;# must be a valid identifier
        upvar $counterName counter

        set counter 0
        if {$exact} {
            set syntax [mib -exact syntax $name]
        } else {
            set syntax [mib syntax $name]
        }
        switch $syntax {
            {OCTET STRING} {
                return ascii
            }
            {OBJECT IDENTIFIER} - IpAddress - TimeTicks - INTEGER - Integer32 - Unsigned32 {
                return dictionary                                         ;# integers are usually enumerations, such as ifOperStatus
            }
            Gauge - Gauge32 {
                return real                  ;# instead of integer since Tcl cannot handle positive integers greater than 0x7FFFFFFF
            }
            Counter - Counter32 - Counter64 {
                set counter 1
                return real                                                            ;# since it is displayed as per second values
            }
            default {
                return dictionary
            }
        }
    }

    proc identifierMessage {name delta} {
        if {$delta} {
            return "(per second for the last polling period)\n[mib description $name]"
        } else {
            return [mib description $name]
        }
    }

    proc update {} {
        variable requestIdentifiers
        variable indexLength
        variable currentRow
        variable busy

        if {[info exist busy]} return                                        ;# wait till request is complete before sending another
        set busy {}
        if {[info exists indexLength]} {                                                                                    ;# table
            catch {unset currentRow}
            getBulk $requestIdentifiers
        } else {
            get $requestIdentifiers
        }
    }

    proc get {identifiers} {
        variable session
        variable trace

        set identifiers [concat sysUpTime.0 $identifiers]
        if {[info exists trace]} {
            puts ">>> request(get-request):[formattedIdentifiers $identifiers]"
        }
        $session get $identifiers {::snmp::processResponse %E %I [list %V]}
    }

    proc getBulk {identifiers} {
        variable session
        variable trace

        set identifiers [concat sysUpTime $identifiers]
        if {[info exists trace]} {
            puts ">>> request(get-bulk-request):[formattedIdentifiers $identifiers]"
        }
        $session getbulk 1 0 $identifiers {::snmp::processBulkResponse %E [list %V]}
    }

    proc formattedIdentifiers {list} {
        set string {}
        foreach identifier $list {
            append string " [mib name $identifier]"
        }
        return $string
    }

    proc formattedObjects {list} {                                                                               ;# list of varbinds
        set string {}
        foreach object $list {
            foreach {identifier type value} $object {}
            append string " [mib name $identifier]($value)"
        }
        return $string
    }

    proc secondsFromSystemUptime {object} {
        foreach {identifier type value} $object {}
        scan $value {%ud %u:%u:%f} days hours minutes seconds
        return [expr {($days*86400)+($hours*3600)+($minutes*60)+$seconds}]                     ;# calculate system uptime in seconds
    }

    # objects are a list of varbinds (see snmp manual page) belonging to the same row
    proc processResponse {status errorIndex objects} {
        variable session
        variable indexColumns
        variable last
        variable data
        variable delta
        variable trace
        variable busy

        unset busy
        if {[info exists trace]} {
            puts "<<< response($status):[formattedObjects $objects]"
        }
        if {![string equal $status noError]} {
            processError $status $errorIndex $objects
        }
        # objects list could be empty or system uptime value missing (may happen in "no such name" error cases):
        catch {set time [secondsFromSystemUptime [lindex $objects 0]]}
        if {![info exists time]} {
            for {set column 0} {1} {incr column} {                                                  ;# make data disappear from view
                if {[catch {unset data(0,$column)}]} break
            }
            catch {unset last(time)}
        } else {
            catch {set period [expr {$time-$last(time)}]}
            set objects [lrange $objects 1 end]                                                              ;# remove system uptime
            set index 0
            foreach object $objects {                                                                     ;# now fill row data cells
                foreach {identifier type value} $object {}
                if {$delta($index)} {
                    set current $value
                    if {[info exists period]} {
                        set value [format %.2f [expr {($current-$last($index))/$period}]]  ;# display deltas per second for counters
                    } else {
                        set value ?                                                   ;# need at least 2 values to make a difference
                    }
                    set last($index) $current
                } elseif {[string equal $type {OBJECT IDENTIFIER}]} {
                    catch {set value [mib name $value]}                                      ;# attempt conversion to readable value
                }
                foreach column $indexColumns($index) {
                    set data(0,$column) $value                                                                ;# there is only 1 row
                }
                incr index
            }
            set last(time) $time
        }
        incr data(updates)
    }

    proc processBulkResponse {status objects} {   ;# objects are a list of varbinds (see snmp manual page) belonging to the same row
        variable requestLength
        variable session
        variable firstIdentifier
        variable indexLength
        variable cachedIndexRow
        variable indexRow
        variable nextRow
        variable currentRow
        variable indexColumns
        variable last
        variable data
        variable delta
        variable trace
        variable busy

        if {[info exists trace]} {
            puts "<<< response($status):[formattedObjects $objects]"
        }
        set error [string compare $status noError]
        if {$error||([llength $objects]!=$requestLength)} {                             ;# number of responses differs from requests
            cleanup
            incr data(updates)
            if {$error} {
                flashMessage "snmp module: got $status error from [$session cget -address]"
            }
            unset busy
            return                                                                                                           ;# done
        }
        set time [secondsFromSystemUptime [lindex $objects 0]]
        set objects [lrange $objects 1 end]                                                                  ;# remove system uptime

        set key {}                                                                                            ;# first determine row
        set index 0
        foreach object $objects {                                                                         ;# first determine the key
            foreach {identifier type value} $object {}
            if {($index==0)&&[string first $firstIdentifier $identifier]} {                                   ;# end of table passed
                cleanup
                incr data(updates)
                unset busy
                return                                                                                                       ;# done
            }
            lappend key $value                                                       ;# concatenate values in a list to make the key
            if {[incr index]==$indexLength} break
        }
        if {[catch {set row $indexRow($key)}]} {                                                                          ;# new row
            if {[catch {set row $cachedIndexRow($key)}]} {         ;# try to use old index so eventual viewers can resume displaying
                set row $nextRow
                set cachedIndexRow($key) $row
                incr nextRow
            }
            set indexRow($key) $row
            if {$indexLength>1} {
                set data($row,0) [expr {$row+1}]                           ;# do not forget creation order column, which starts at 1
            }
        } else {
            set period [expr {$time-$last($row,time)}]
        }
        set currentRow($row) {}                                                            ;# keep track of current rows for cleanup
        set index 0
        set identifiers {}
        foreach object $objects {                                                                         ;# now fill row data cells
            foreach {identifier type value} $object {}
            lappend identifiers $identifier
            if {$delta($index)} {
                set current $value
                if {[info exists period]} {
                    set value [format %.2f [expr {($current-$last($row,$index))/$period}]] ;# display deltas per second for counters
                } else {
                    set value ?                                                       ;# need at least 2 values to make a difference
                }
                set last($row,$index) $current
            } elseif {[string equal $type {OBJECT IDENTIFIER}]} {
                catch {set value [mib name $value]}                                          ;# attempt conversion to readable value
            }
            foreach column $indexColumns($index) {
                set data($row,$column) $value                                                ;# fill the columns for that identifier
            }
            incr index
        }
        set last($row,time) $time
        getBulk $identifiers                                                                         ;# keep going till end of table
    }

    proc cleanup {} {                                                                 ;# remove disappeared rows and associated data
        variable currentRow
        variable indexRow
        variable data
        variable last
        variable numberOfColumns

        foreach {key row} [array get indexRow] {
            if {[info exists currentRow($row)]} continue
            unset indexRow($key)
            for {set column 0} {$column<$numberOfColumns} {incr column} {
                unset data($row,$column)
            }
            array unset last $row,*
        }
        catch {unset currentRow}
    }

    proc processError {status errorIndex objects} {
        variable session

        set message "snmp module: got $status error from [$session cget -address]"
        if {$errorIndex>0} {
            foreach {identifier type value} [lindex $objects [expr {$errorIndex-1}]] {}                   ;# error index starts at 1
            if {[info exists identifier]} {
                append message " for [mib name $identifier] identifier"
            } else {
                append message " at index $errorIndex"
            }
        }
        flashMessage $message
    }

}
