#---------------------------------------------------------------------------- 
#
# Blueline (tm) v 1.0
#
# An email preview and filter (tobe)
#
# Copyright 20003, Roy Terry
#
# LICENSE:
# This software (Blueline version 1.0) is made freely available for any use with no 
# warranty whatsoever.

# INSTALL AND CONFIGURE
#   1. Requires (excellent) tabllist package (pure tcl megawidget) be installed
#      http://home.t-online.de/home/csaba.nemethi
#   2. Edit "array set sp" below an put in values for host, login, pass
#   3. For Windows must have "patched" pop3.tcl: pop3-winfix.tcl in the 
#      startup directory.
#      On other systems the native tcllib version of pop3 probably works fine
#   4. May work on 8.3 but was built and tested with Tcl/Tk 8.4
#
# CHANGES:
#   8Oct2003 - release of 1.0 to Tcl Wiki
#  16Oct2003 - added sorting by column
#  18Oct2003 - added initial rule eval using rule.tcl
#---------------------------------------------------------------------------- 


# Main User settings here
# SET EMAIL SERVER INFO HERE

error "set server login paramters below"
array set sp {
    host  ?
    login ?
    pass  ?
    autominutes 3
    dolog 1
    toplines 100
}

# More internal settings here
array set sp {
    logname bline.log
    confname bline.cfg
    deletedone 0
    firsttime 1
    lastfetch 0
    msgcount 0
    ch  {}
    wprog .prog
    app,title {Blue Line}
    app,ver 1.0
    app,tm \u2122
    font,title,desc {-family helvetica -size 14 -slant italic}
    font,tm,desc {-family helvetica -size 12 -slant italic}
    font,op,desc {-family helvetica -size 12 }
    font,mhdrs,desc {-family helvetica -size 10 -weight bold}
    color,title,fg white
    color,title,bg navy
    color,blue1 navy
    color,blue2 dodgerblue
}

# Main display fields for message info
array set msgFields {
    order {num rule to from subject}
    num,width 4
    num,title #
    to,width 15
    to,title To
    from,width 25
    from,title From
    subject,width 70
    subject,title Subject
    rule,width 8
    rule,title Rule
}

if { $sp(dolog)} {
    set sp(log) [open $sp(logname) a]
    fconfigure $sp(log) -buffering line
}

if {$tcl_platform(platform) == "windows"} {
    # source pop3-winfix.tcl ;# Custom version with bug fix for windows
    # source c:/roy/tcl/pop3.tcl ;# v 1.6 vanilla
    package require pop3
} else {
    package require pop3
}
# proc log::log args {} ;# kill off debug messages from pop3
# package require log
log::lvSuppressLE critical 0 ;# request by Andreas Kupries

proc bgerror args { spLog "BGERROR: [join $args]"}

proc spConnect { {noShow 0} } {
    global sp
    if { ! $noShow} {spWinProgressShow Connecting}
    # Connect and get count/size info
    if {[catch {
        set sp(ch) [pop3::open $sp(host) $sp(login) $sp(pass)]
    } msg]} {
            set sp(errConn) $msg
            return 0
    }

    foreach {cnt by8} [pop3::status $sp(ch)] break
    set sp(bytes) [expr {$by8 * 8}]
    set sp(cnt) $cnt
    set sp(timecon) [clock seconds]
    set sp(timeconMM) [clock clicks -milliseconds]
    return 1
}
proc spTopFetchAll {nlines {errVAR ""} } {
    # Do top command for nlines on every message
    # return list of results

    set dog [clock seconds]

    global sp
    if {$sp(ch) == ""} {
        return [list]
    }
    if {$errVAR != ""} {upvar $errVAR errout}

    set toplist [list]
    for {set mi 1} {$mi <= $sp(cnt)} {incr mi} {
        spLog "spTopFetchAll: $mi"
        if {[catch {
            set t [pop3::top $sp(ch) $mi $nlines]
        } msg ]} {
            set errout $msg
            return $toplist
        }
        spWinProgressUpdate \
            "No. $mi of $sp(cnt)" \
            [expr {(100*$mi)/$sp(cnt)}]

        lappend toplist $t
        if {$dog + 50 < [clock seconds]} {
            set errout "too long: 50 seconds! mi=$mi"
            return $toplist
        }
    }
    return $toplist

}
proc spClose {} {
    global sp
    if {$sp(ch) == ""} return
    pop3::close $sp(ch)
    set sp(ch) ""
}

proc spUtilListTops {} {
    # DISUSED and obsolete 
    set mi 0
    set out ""
    foreach mt [spTopFetchAll 10] {
        incr mi
        set sub [spUtilHdrParse subject $mt]
        set from [spUtilHdrParse from $mt]
        lappend out "[format %2d $mi] [format %.35s $from] => $sub"
    }
    return $out
}
proc spUtilFetchOneMsg {mi} {
    global sp
    return [join [pop3::retrieve $sp(ch) $mi]]
}
proc spUtilHdrParse {hname buf} {
    # Return the contents of the named header from the buffer
    # Also respect special names for body and "all"
    # BEWARE: body is limited by the size of "top" that was fetched
    # append RE \n$hname: " " {([^\n]+)}

    # 23Oct03RT - correction for multi-line headers
    # The values of the header instances get concatenated in our
    # return. May be surprising for Received: and Content-Type: etc.
    # Matches anything upto either a blank line or start of another
    # header. (?=re) says to do this non-greedily so we only do get 1 header
    append RE \n$hname: " " {(.*?)(?=(\n\n|\n[A-Z]))}

    switch [string tolower $hname] {
        body {
            # Everything below the headers
            set i [string first \n\n $buf]
            incr i 2
            return [string range $buf $i end]
        }
        all {
            return $buf
        }
        default {
            # Assume it's a header
            if { ! [string match -nocase *$hname* "from to subject cc bcc"]} {
                spLog uncommon header request: $hname
            }
            # Loop to process all matches
            set out ""
            # if {[regexp -nocase $RE $buf => content]} {}
            foreach {_ content} [regexp -all -inline -nocase $RE $buf] {
                append out $content " "
            } 
            return $out
        }
    }
}

proc spWinProgressUpdate {opnums percent} {
    global sp

    # Catch in case window is not in use, etc.
    catch {
        set sp(opnums) $opnums

        # now calc how big to make progress bar
        set pwidth [winfo width [winfo parent $sp(wpercent)]]

        set w [expr {round (($percent*$pwidth)/100.0)}]
        $sp(wpercent) configure -width $w
    }
    update
    # after 100
}
proc spWinProgressHide {} {global sp; destroy $sp(wprog)}
proc spWinProgressShow {op {opnums ""} } {
    global sp
    # Create or show the in-progress window to display
    # download/kill activities
    set tlev $sp(wprog)
    destroy $tlev
    toplevel $tlev -width 300 -height 150 -bd 5 -relief raised
    wm overrideredirect $tlev 1
    wm geometry $tlev +300+250
    $tlev config -bg black

    # Layout: Title/action
    #         -------------
    #         (graphic progress)
    set col 0
    1line {grid [label $tlev.ltitle
            -font [spFont title]
            -text $sp(app,title)
            -fg $sp(color,title,fg)
            -bg $sp(color,title,bg)
            -bd 0
            ] -column $col -row 0 -sticky news
    }
    incr col
    # TM gets smaller font
    1line {grid [label $tlev.ltm
            -font [spFont tm]
            -text $sp(app,tm)
            -fg $sp(color,title,fg)
            -bg $sp(color,title,bg)
            -bd 0
            ] -column $col -row 0 -sticky news
    }
    incr col
    # Word or 2 telling what we're doing
    1line {grid [label $tlev.lop
            -font [spFont op]
            -text " - $op "
            -fg $sp(color,title,fg)
            -bg $sp(color,title,bg)
            ] -column $col -row 0 -sticky news
    }
    incr col
    # Numbers telling amount left (10%) or (5 of 12) etc
    set sp(opnums) $opnums
    1line {grid [label $tlev.lopnums
            -font [spFont op]
            -textvariable sp(opnums)
            -fg $sp(color,title,fg)
            -bg $sp(color,title,bg)
            ] -column $col -row 0 -sticky news
    }
    # Graphic progress line is a frame on 2nd row
    set sp(wpercent) $tlev.fgraph
    1line {grid [frame $sp(wpercent)
            -bg $sp(color,blue2)
            -height 7
            ] -column 0 -row 1 -sticky w -padx 5 
               -columnspan [lindex [grid size $tlev] 0]
    }

    raise $tlev
}
proc spFont {fname} {
    # lookup or create configured font as needed
    global sp
    
    if {[info exists sp(font,$fname,name)]} {
        return $sp(font,$fname,name)
    }
    set sp(font,$fname,name) [eval font create $sp(font,$fname,desc)]
}
proc spCmdFrameFill {f} {
    # Create and configure main command button group in frame f
    # Future clearly distinguish buttons operating on message list,
    # from those operating on the window itself.
    set bi -1
    foreach {bt bid} {
        "Delete Msgs" delete \
        "Select All" selall \
        "Shutdown" close \
        Refresh refresh \
        Hide hide\
        "All Trash" alltrash } {
        incr bi
        set w [button $f.$bid \
            -pady 0 -bd 1 \
            -text $bt -padx 6 -command "spCmdDo $bid"]
        grid $w -column $bi -row 0 -sticky s -padx 8 -pady {10 4}
    }
}
proc spCmdDo cmd {
    global sp msgFields
    set tl $sp(w,tl)
    spLog "CMD: $cmd"
    switch $cmd {

        alltrash {
            # recursive shortcut
            spCmdDo hide
            spCmdDo selall
            spCmdDo delete
        }
        hide     {wm iconify .}
        refresh  {runPrimative}
        close    {destroy .; exit}
        selall   {$tl selection set 0 end }
        delete {
            
            if {$sp(deletedone)} return ;# safety on scaffold coding


            set sp(ch) [pop3::open $sp(host) $sp(login) $sp(pass)]
            
            # Notice that the list may be in any order so we must use the
            # msg number field. "num"
            set milist ""
            set numcol [lsearch $msgFields(order) num]
            set ilist [$tl curselection]
            foreach i [$tl curselection] {
                # pulling only the num column value and trimming whiteness
                lappend milist [string trim [lindex [$tl get $i] $numcol] ]
            }
    # puts "milist: $milist"
    # puts "ilist: $ilist"
    # spClose
    # return

            # Delete in backwards order just in case the server is
            # non spec-compliant
            set milist [lsort -integer -decreasing $milist]
            foreach mi $milist {
                pop3::delete $sp(ch) $mi
            }

            # Now delete same from gui widget
            foreach i [lsort -integer -decreasing $ilist] {
                $tl delete $i
            }
            spClose
            set sp(deletedone) 1
            set sp(msgcount) [$tl index end]
            wm title . "$sp(msgcount) - $sp(app,title) "
        }
    }
}

proc spMainFrameFill {f} {
    # put display of msg fields and per msg info into the frame
    # todo: display how long since fetch occurred
    global msgFields sp
    package require tablelist

    if {$f == "."} {set f ""}

    # 1 Configure the tablelist widget

    set tlf $f.tlf
    if {[winfo exists $tlf]} {
        $tlf.tl delete 0 end
        set sp(w,tl) $tlf.tl
        return
    }
    frame $tlf

    foreach fld $msgFields(order) {
        lappend clist $msgFields($fld,width)
        lappend clist $msgFields($fld,title)
    }


    set tl $tlf.tl
    set sy $tlf.sy
    set sx $tlf.sx
    1line { tablelist::tablelist $tl 
        -labelfont [spFont mhdrs]
        -labelrelief solid
        -labelcommand tablelist::sortByColumn
        -labelborderwidth 1
        -background lightcyan2
        -stripebackground darkseagreen1
        -selectmode multiple
        -showseparators yes
        -columns $clist 
        -xscrollcommand "$sx set" 
        -yscrollcommand "$sy set"
    }

    scrollbar $sy -orient vertical -command "$tl yview"
    scrollbar $sx -orient horizontal -command "$tl xview"

    pack $sy -side right -fill y
    pack $sx -side bottom -fill x
    pack $tl -side top -fill both -expand 1
    pack $tlf -fill both -expand 1

    set sp(w,tl) $tl

}
proc spMsgDisplayAdd {num mbuf} {
    # Add the numbered message to the tabular display
    global sp msgFields
    set tl $sp(w,tl)

    set item ""
    foreach fld $msgFields(order) {
        switch -regexp $fld {
            num {
                lappend item [format %3d $num]
            }
            to|from|subject {
                lappend item [spUtilHdrParse $fld $mbuf]
            }
            rule {
                # 18Oct03RT - display calculated rule findings
                lappend item [msgRuleEvalAll $mbuf]
            }
        }
    }
    $sp(w,tl) insert end $item
}

proc runPrimative { {noShow 0} } {
    # for use in devel startup and refresh
    global sp
    spConnect $noShow
    if { ! $noShow} { spWinProgressShow "Fetching tops"}

    if {$sp(firsttime)} {
        set fcmd [frame .fcmd]
        pack $fcmd -side bottom -fill x
        spCmdFrameFill $fcmd

        spMainFrameFill .
        bind . <Map>        "spShowing %W"
        # wm geometry . 700x600+200+100
    } else {
        $sp(w,tl) delete 0 end
        set sp(toplist) [list]
    }
    set mi 0
    set err ""
    foreach mt [spTopFetchAll $sp(toplines) err] {
        spLog "Fetchall error was \"$err\""
        incr mi
        lappend sp(toplist) $mt
        spMsgDisplayAdd $mi $mt
    }
    set sp(lastfetch) [clock seconds]

    if { ! $noShow} {
        spWinProgressHide 
        wm deiconify .
        focus -force .
    }
    set sp(msgcount) $mi
    wm title . "$mi - $sp(app,title) "

    spClose
    set sp(firsttime) 0
    set sp(deletedone) 0
}
proc runAuto {} {
    # keep ourselves updated automatically 
    # when **ICONIFIED**
    global sp
    set after [expr {$sp(autominutes)*1000*60}]
    set oldcnt $sp(msgcount)
    set ts [clock format [clock seconds]]
    if { [winfo ismapped .] } {
        spLog "skip Auto ref. dot is mapped - $ts"
        after $after runAuto
        return
    }
    if {[winfo exists $sp(wprog)] } {
        spLog "skip Auto ref. prog win exists -  $ts"
        after $after runAuto
        return
    }

    spLog "Auto refresh on Timer at $ts"
    runPrimative 1 ;# refresh w/o deiconify or progress window
    if {$sp(msgcount) > 0 && $oldcnt != $sp(msgcount)} bell

    after $after runAuto
}
proc spShowing {win} {

    if {$win != "."} return
    global sp

    set now [clock seconds]
    if {$sp(lastfetch) == 0} return

    # if we're getting shown and it's been at least 60 seconds
    # then refresh data
    if {$sp(lastfetch)+60 < $now} {
        spLog "Auto refresh on <Map> at [clock format $now]"
        runPrimative
    }
}
proc spLog {args} {
    global sp
    if {$sp(dolog)} {
        puts $sp(log) [join $args]
    }
}

#---------------------------------------------------------------------------- 
#  Utility procs

proc 1line {code} {return [uplevel [string map {\n " "} $code]]}

proc spDataSave {} {
    # save a list of global variables
    set alist [list sp ruleData msgRules ]
    eval global $alist

    set ch [open $sp(confname) w]

    foreach a $alist {
        puts -nonewline $ch "$a "
        puts $ch [array get $a]
    }
    close $ch
}
proc spDataLoad {filebase varPRE} {
    # Create a set of global vars from a previous time
    # prefix their names with $varPRE
    set ch [open $sp(confname) r]
    while {[gets $ch line] > 0} {
        scan $line %s v
        set var ${varPRE}$v
        global $var
        array unset $var
        array set $var [string range $line [string length $var] end]
    }
    close $ch
}

#
#---------------------------------------------------------------------------- 
proc spStartup {} {
    global sp tcl_platform
    package require Tk
    wm withdraw .
    eval destroy [winfo child .]
    wm title . "$sp(app,title) "
    if {$tcl_platform(platform) == "windows"} {
        wm iconbitmap . sp1.ico
    }
    runPrimative
    after 5000 runAuto
}

# source rules.tcl
#------------------------------------------------------------------------------ 
#
# Blueline - spam filter: rules.tcl evaluates rules against email messages
#            and returns results.
#
#   LOG:
#       16Oct03RT - created file
#------------------------------------------------------------------------------ 


# A rule is a list of name/value pairs with certain element names required
# and various rules placed on the values associated with some names

if {0} {
 RULES - EVOLVING CONCEPTS:
    1. use special "key words" like all caps to refer to special parts of
       the message begin tested: eg. FROM, SUBJECT, TO, BODY
       These special parts can be the names of commands that interp their
       arguments appropriately and return true/false. All rule commands
       occurring in condition clauses will received the email itself as thier
       first argument.
    2. Consider using special syntax to let rule refer to varying data such
       as list of friends. @? $? other?
    3. Each rule has list of actions it will perform if it evals true. Actions
       are predefined Tcl commands.
 TODO:
    - organize global storage for rules and data they will refer to
}

# 18Oct03RT - manually entered rules+data for devel/test
# TODO - get this into .dat file and out of distributed source
#        file!

# For the friends list any particular fragment of the address
# we choose should be serviceable.
# "friends" is used in "fromfriends" rule to test against the FROM
# header of an email
1line {set ruleData(friends)
 [list
    "greg hume"
    ridley
    lynn.rogers
    gbs@redback
    tcl-core
    nytdirect@nytimes.com
 ] }


# A rule to recognize and favor email from "friends"
array set msgRules ""
lappend msgRules(rules) {
    id 1
    name fromfriends
    condition {
        [FROM containsOne @friends@]
    }
    action {a-friend}
}
lappend msgRules(rules) {
    id 2
    name badto
    condition {
        [TO lacks royterry@earthlink.net]
    }
    action {x-badTO}
}
proc TO {relop dataref} {
    global ruleData
    # Since we don't want implied argument of msgbuf to 
    # appear in conditions we insert it here 
    set mbuf $ruleData(curbuf)
    return [msgRuleOnField to $mbuf $relop $dataref]
}
proc FROM {relop dataref} {
    global ruleData
    # Since we don't want implied argument of msgbuf to 
    # appear in conditions we insert it here 
    set mbuf $ruleData(curbuf)
    return [msgRuleOnField from $mbuf $relop $dataref]
}
proc msgRuleEvalAll {mbuf} {
    # Run the msg against all rules and return a
    # list of action findings
    global msgRules ruleData errorInfo
    set ruleData(curbuf) $mbuf
    set acts [list]
    foreach rl $msgRules(rules) {
        array unset r
        array set r $rl
        if {[catch {set hit [expr $r(condition)] } msg]} {
            # Eval caused an error - this rule will fail
            set hit 0
            spLog conditions error on rule $r(id) $r(name) $msg \n$errorInfo
            puts stderr "conditions error on rule $r(id) $r(name) $msg \n$errorInfo"
        } 
        if {$hit} { lappend acts $r(action) }
    }
    if {$acts == ""} {return none} {return $acts}
}

proc msgRuleOnField {field mbuf relop dataref} {
    # Implements heart of FROM TO SUBJECT and similar
    # procs which are commonly used in rule condition clauses
    global ruleData

    # 1. resolve the dataref. Literal or symbolic
    if {[string match @*@ $dataref]} {
        set dataref [string range $dataref 1 end-1]
        if {! [info exists ruleData($dataref)]} {
            spLog bad dataref @$dataref@
            return 0 ;# "false"
        } else {
            set dat $ruleData($dataref)
        }
    } else {
        set dat $dataref
    }
    # get the field value
    set fval [spUtilHdrParse $field $mbuf]
    switch $relop {
        lacks {
            # True if the msg field doesn't contain the dat value
            if {[string match -nocase *$dat* $fval] == 0} {
                return 1 
            } else {
                return 0
            }
        }
        contains {
            if {[string match -nocase *$dat* $fval]} {
                return 1
            } else {
                return 0
            }
        }
        containsOne {
            # A literal check against a list. IOW, does the email
            # field literally contain one of the list elements
            # contains is a literal check (but caseless)
            foreach de $dat {
                if {[string match -nocase *$de* $fval]} {
                    return 1
                }
            }
            return 0
        }
    }
}


# Hokey startup for daily use while building
# if { [info exists argv] && $argv == "autostart"} spStartup
spStartup

