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


package provide log [lindex {$Revision: 1.17 $} 1]
package require network 1


namespace eval log {

    variable numbers {}
    variable nextNumber 0

    array set data {
        updates 0
        0,label {} 0,type integer 0,message {row index (0 is always the 'top' type row)}
        1,label date 1,type clock 1,message {date of last message occurrence of its sort}
        2,label time 2,type clock 2,message {time of last message occurrence of its sort}
        3,label occurences 3,type integer 3,message {number of occurrences of this sort of message since this module was launched}
        4,label host 4,type dictionary 4,message {host that produced the message}
        5,label source 5,type ascii 5,message {source of last message occurrence of its sort}
        6,label message 6,type ascii 6,message {processed message text of its sort (variants appear as ?)} 6,anchor left
        views {{indices {1 2 3 4 5 6}}}
        persistent 0
        switches {-f 1 --file 1 -r 1 --remote 1 --rows 1 --whole 0}
    }
    set file [open log.htm]
    set data(helpText) [read $file]                                                           ;# initialize HTML help data from file
    close $file
    unset file

    proc initialize {optionsName} {
        upvar 1 $optionsName options
        variable remote
        variable data
        variable numberOfRows
        variable log

        set numberOfRows 10                                                                                            ;# by default
        catch {set numberOfRows $options(--rows)}
        if {$numberOfRows <= 0} {set numberOfRows 2147483647}                                            ;# eventually no limitation
        if {[string equal $::tcl_platform(os) SunOS]} {
            set log(file) /var/log/syslog
        } else {
            set log(file) /var/log/messages                                                                            ;# by default
        }
        catch {set log(file) $options(-f)}                                                          ;# eventually overridden by user
        catch {set log(file) $options(--file)}                                                                  ;# favor long option

        if {![catch {set locator $options(--remote)}] || ![catch {set locator $options(-r)}]} {                 ;# remote monitoring
            set data(pollTimes) {30 20 60 120 300 600}                                   ;# poll less often when remotely monitoring
            foreach {remote(protocol) remote(user) remote(host)} [network::parseRemoteLocator $locator] {}
            network::checkRemoteOutputEmptiness $remote(protocol) $remote(user) $remote(host)
            set data(identifier) log($remote(host))

            # first see if the file is readable at all (use tail as file may be huge but must be read till the end (see below)):
            if {[string equal $::tcl_platform(platform) unix]} {
                set remote(command) "$remote(protocol) -n -l $remote(user) $remote(host) tail $log(file)"
            } else {                                                                                                      ;# windows
                set remote(command) "plink -batch $remote(host) tail $log(file)"                   ;# host is rather a putty session
            }
            set file [open "| $remote(command)"]
            fileevent $file readable {set ::log::remote(busy) 0}
            vwait ::log::remote(busy)                                                                  ;# do not hang user interface
            # detect errors early (but avoid write on pipe with no readers errors by reading whole data)
            if {[catch {read $file} message] || [catch {close $file} message]} {
                error "on remote host $remote(host) as user $remote(user): $message"
            }
            if {[string equal $::tcl_platform(platform) unix]} {
                set remote(command) "$remote(protocol) -n -l $remote(user) $remote(host) ls -l $log(file)"
            } else {                                                                                                      ;# windows
                set remote(command) "plink -batch $remote(host) ls -l $log(file)"                  ;# host is rather a putty session
            }
            set file [open "| $remote(command)"]
            fileevent $file readable {set ::log::remote(busy) 0}
            vwait ::log::remote(busy)
            catch {unset line}
            # detect errors early (but avoid write on pipe with no readers errors by reading whole data):
            if {[catch {gets $file line; read $file; close $file} message]} {
                error "on remote host $remote(host) as user $remote(user): $message"
            }
            if {![info exists line]} {
                error "could get information on file $log(file) on remote host $remote(host)"
            }
            if {[string match *->* $line]} {                                                          ;# the file is a symbolic link
                error "file $log(file) on remote host $remote(host) is a symbolic link (unimplemented):\n$line"
            }
            if {[info exists options(--whole)]} {                                             ;# read the whole file at first update
                set log(position) 0
            } else {                                                                                ;# process new lines from now on
                set log(position) [lindex $line end-4]                                  ;# point to the file end position (its size)
            }
        } else {
            set data(pollTimes) {20 10 30 60 120 300 600}
            set log(channel) [open $log(file)]                                        ;# keep local file open for better performance
            # so that lines are trimmed only by 1 character by gets on windows, in order to always get the byte count right:
            fconfigure $log(channel) -translation binary
            gets $log(channel)         ;# attempt to validate file by reading a single line in case file is a directory, for example
            if {[info exists options(--whole)]} {
                seek $log(channel) 0 start
            } else {
                seek $log(channel) 0 end                                                            ;# process new lines from now on
            }
        }
    }

    proc update {} {
        variable remote
        variable log
        variable data
        variable messageData
        variable messageNumber
        variable nextNumber
        variable numbers                                                                             ;# displayed at the last update
        variable numberOfRows

        if {[info exists remote]} {
            if {![info exists log(channel)]} {                             ;# start data gathering process in a non blocking fashion
                if {$remote(busy)} return                                           ;# core invocation while waiting for remote data
                set remote(busy) 1
                set command "dd bs=1 skip=$log(position) if=$log(file)"
                if {[string equal $::tcl_platform(platform) unix]} {
                    append command " 2> /dev/null"                                              ;# suppress dd informational message
                    set file [open "| $remote(protocol) -n -l $remote(user) $remote(host) $command"]
                } else {                                                                                                  ;# windows
                    append command " 2> NUL:"                                                   ;# suppress dd informational message
                    set file [open "| plink -batch $remote(host) $command"]
                }
                # so that lines are trimmed only by 1 character by gets on windows, in order to always get the byte count right:
                fconfigure $file -translation binary
                # do not hang GUI, allow other modules updates
                fileevent $file readable "set ::log::log(channel) $file; ::log::update"
                return                                                                                       ;# wait for remote data
            }                                                                                 ;# else continue below to process data
        }
        while {[set length [gets $log(channel) line]] >= 0} {
            if {[info exists remote]} {                                                                  ;# keep track of bytes read
                incr log(position) $length
                incr log(position)                                                              ;# count stripped new line character
            }
            if {[scan $line "%s %u %u:%u:%u %s %\[^:\]: %\[^\n\]" month day hours minutes seconds host source message] != 8}\
                continue
            set message [string trim $message]                                                  ;# in case there are trailing blanks
            set replaced [regsub -all {\d+} $message ? pattern]                                                ;# replace all digits
            if {[catch {set number $messageNumber($host,$pattern)}]} {
                set number $nextNumber
                set messageNumber($host,$pattern) $number
                set messageData(count,$number) 1
                set messageData(common,$number) $message
                incr nextNumber
            } else {
                if {$replaced > 0} {
                    set messageData(common,$number) [merged $messageData(common,$number) $message]
                }                                                                                 ;# else message is always the same
                incr messageData(count,$number)
            }
            set messageData(date,$number) "$month [format %02u $day]"
            set messageData(time,$number) [format %02u:%02u:%02u $hours $minutes $seconds]
            set messageData(host,$number) $host
            set messageData(source,$number) $source
            lappend numbers $number
        }
        if {[info exists remote]} {
            # avoid write on pipe with no readers errors by reading remaining data (communication error can be detected here)
            if {[catch {read $log(channel); close $log(channel)} message]} {
                flashMessage "error: $message"
            }
            unset log(channel)
            set remote(busy) 0
        }
        array unset data {[0-9]*,[0-9]*}                                                                    ;# clear data every time
        set newNumbers {}
        set row 0
        for {set index [expr {[llength $numbers] - 1}]} {$index >= 0} {incr index -1} {            ;# scan numbers most recent first
            set number [lindex $numbers $index]
            if {[info exists displayed($number)]} continue
            set data($row,0) $row
            set data($row,1) $messageData(date,$number)
            set data($row,2) $messageData(time,$number)
            set data($row,3) $messageData(count,$number)
            set data($row,4) $messageData(host,$number)
            set data($row,5) $messageData(source,$number)
            set data($row,6) $messageData(common,$number)
            set displayed($number) {}
            set newNumbers [linsert $newNumbers 0 $number] ;### optimize ###
            if {[incr row] >= $numberOfRows} break
        }
        set numbers $newNumbers                                                            ;# keep displayed numbers for next update
        incr data(updates)
    }

    proc merged {current new} {
        set length [string length $current]
        if {[string length $new] == $length} {                              ;# same length: do a character per character replacement
            for {set index 0} {$index < $length} {incr index} {
                if {[string compare [string index $new $index] [string index $current $index]]} {
                    set current [string replace $current $index $index ?]
                }
            }
            return $current
        } else {                                                                            ;# differents lengths: process each word
            set words {}
            foreach reference [split $current] word [split $new] {
                if {![regexp {\d} $word]} {                                                                     ;# no digits in word
                    lappend words $word
                    continue                                                                                      ;# skip processing
                }
                set length [string length $reference]
                if {[string length $word] == $length} {                     ;# same length: do a character per character replacement
                    for {set index 0} {$index < $length} {incr index} {
                        if {[string compare [string index $word $index] [string index $reference $index]]} {
                            set reference [string replace $reference $index $index ?]
                        }
                    }
                    lappend words $reference
                } else {
                    regsub -all {\d+} $reference ? word
                    lappend words $word
                }
            }
            return [join $words]
        }
    }

}
