Attachment "roytest2.tcl" to
ticket [815405ffff]
added by
royterry
2003-11-01 01:28:01.
#----------------------------------------------------------------------------
#
# 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
[email protected]
] }
# 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 [email protected]]
}
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
