Another NNTP Reader ,by PYK, initially based on A little NNTP reader, is a smallish NNTP reader that uses tcllib's nntp module behind the scenes. I have some hope that its interface will prove usable under AndroWish on small devices, but haven't tried it on that platform. In the next few days I plan to add the ability post messages, and to save state to disk. I'll be interested to hear if it works under AndroWish, and what interface changes would be needed to make it more usable. I'm actively soliciting constructive opinions on all aspects of the code below, "constructive" being interpreted very loosely, so please let fly with the comments and suggestions!
This program is configured by default to open comp.lang.tcl
#! /bin/env tclsh
package require Tk
package require nntp
namespace import ::tcl::mathfunc::*
namespace import ::tcl::mathop::*
proc sproc {name argspec svars body} {
set script [string map [list {{{svars}}} [list $svars]] {
variable state
foreach varname [set svars {{svars}}] {
upvar 0 state($id,$varname) $varname
}
}]
proc $name $argspec "$script$body"
}
proc scrolledlist {id parent data selected updater} {
scrollbar $parent.y -command [
list $parent.l yview]
listbox $parent.l -yscrollc [list $parent.y set]
set max 20
foreach data1 $data {
$parent.l insert end $data1
set max [max [string length $data1] $max]
if {$selected eq $data1} {
$parent.l selection set end
}
}
$parent.l configure -width $max
foreach sequence {<Double-Button-1> <Return>} {
bind $parent.l $sequence [namespace code $updater]
}
bind $parent.l <Escape> [namespace code [list goback $id]]
}
proc main argv {
set id [info cmdcount]
set frame [frame .[info cmdcount]]
pack $frame -fill both -expand 1
ui $id $frame
}
sproc ui {id args} {busy deadhosts displayheaders firstload fromcolor group
host hosts lastgroup load loaded n username password newcolor readcolor
replycolor subjectcolor w winstack} {
variable defaults
set args [lassign $args w]
dict with defaults {}
dict with args {}
set busy {}
text [frame $w.intro].msg
foreach phrase {
{{A little NNTP Reader} bold \n\n}
{{General Keys:} bold \n\n}
{{Escape {return to previous screen}} {} \n}
{{Return continue} {} \n\n}
{{Message List Keys:} bold \n\n}
{{m {load more messages}} {} \n\n}
{{Message Keys:} bold \n\n}
{{h {view headers}} {} \n}
{{n {next message}} {} \n}
{{p {previous message}} {} \n}
{{b {backward in thread}} {} \n}
{{f {forward in thread}} {} \n}
} {
$w.intro.msg insert end {*}$phrase
}
$w.intro.msg mark set insert 1.0
$w.intro.msg tag configure bold -font bold
textwrapper $w.intro.msg
bind $w.intro.msg <Return> [list uiswitch $id ui_hosts]
bind $w.intro.msg <Escape> [list goback $id]
set load $firstload
scrolledlist $id [frame [frame $w.hosts].listf] $hosts $host [
list hosts_entry_update $id %T]
entry $w.hosts.entry -textvar [namespace current]::state($id,host)
foreach sequence {<Double-Button-1> <Return>} {
bind $w.hosts.entry $sequence [
namespace code [list uiswitch $id ui_authentication]]
}
label [frame [frame $w.authentication].username].label -text username
entry $w.authentication.username.entry -textvariable [
namespace current]::state($id,username)
bind $w.authentication.username.entry <Return> [
list ui_connect $id]
bind $w.authentication.username.entry <Escape> [
list goback $id]
label [frame $w.authentication.password].label -text password
entry $w.authentication.password.entry -textvariable [
namespace current]::state($id,password] -show 0
bind $w.authentication.password.entry <Return> [
list ui_connect $id]
bind $w.authentication.password.entry <Escape> [
list goback $id]
label [frame $w.connect].msg -text Connecting...
scrolledlist $id [frame [frame $w.groups].listf] {
{double-click to load groups}
} $group [list getgroups $id]
$w.groups.listf.l configure -width 27
entry $w.groups.entry -textvariable [namespace current]::state($id,group)
bind $w.groups.entry <Return> [list uiswitch $id ui_group]
bind $w.groups.entry <Escape> [list goback $id]
scrolledlist $id [frame $w.x] {} {} [list uiswitch $id ui_message]
bind $w.x.l <Escape> [list goback $id]
bind $w.x.l m [list moremessages $id]
set textopts {-wrap word -padx 5 -pady 3
-height 12 -font {Helvetica 9}}
frame $w.h
scrollbar $w.h.y -command [list $w.h.t yview]
textwrapper [text $w.h.t {*}$textopts -yscrollc [list $w.h.y set]]
foreach color [list $fromcolor $replycolor $subjectcolor] {
$w.h.t tag configure $color -foreground $color
}
bind $w.h.t h [list ui_header $id]
frame $w.f
scrollbar $w.f.y -command [list $w.f.t yview]
textwrapper [text $w.f.t {*}$textopts -yscrollc [list $w.f.y set]]
foreach color [list $fromcolor $replycolor $subjectcolor] {
$w.f.t tag configure $color -foreground $color
}
bind $w.f.t <Escape> [list goback $id]
bind $w.f.t h [list ui_header $id]
bind $w.f.t n [list nextmessage $id]
bind $w.f.t p [list prevmessage $id]
bind $w.f.t b [list threadmove $id -1]
bind $w.f.t f [list threadmove $id 1]
label $w.status
uiswitch $id ui_intro
}
sproc uiswitch {id next args} {w winstack} {
lappend winstack $next
pforget $w
$next $id {*}$args
}
sproc ui_intro id {w winstack} {
pack $w.intro {*}[winfo children $w.intro]
focus $w.intro.msg
}
sproc ui_hosts id {w winstack} {
pack $w.hosts $w.hosts.listf
pack $w.hosts.listf.y -fill y -side right
pack $w.hosts.listf.l -fill both -expand 1
pack $w.hosts.entry -fill x -expand 1
focus $w.hosts.listf.l
}
sproc ui_authentication id {w winstack} {
pack $w.authentication {*}[winfo children $w.authentication] {*}[
winfo children $w.authentication.username] {*}[
winfo children $w.authentication.password]
focus $w.authentication.username.entry
}
sproc ui_connect id w {
pack $w.connect [winfo children $w.connect]
connect $id
}
sproc ui_groups id w {
pack $w.groups -fill y -expand 1
pack $w.groups.listf -fill y -expand 1
pack $w.groups.listf.y -side right -fill y
pack $w.groups.listf.l -fill y -expand 1
pack $w.groups.entry -fill x
if {[$w.groups.listf.l index end] > 1} {
focus $w.groups.listf.l
} else {
focus $w.groups.entry
}
}
sproc ui_group id {w} {
pack $w.x -fill both -expand 1
pack $w.x.y -fill y -side right
pack $w.x.l -fill both -expand 1 -side right
pack $w.status -fill y -side bottom
focus $w.x.l
messages $id
}
sproc ui_header id {displayheaders w} {
set displayheaders [! $displayheaders]
uiswitch $id ui_message
}
sproc ui_message id {displayheaders w} {
if {$displayheaders} {
pack $w.h -fill both
pack $w.h.y -fill y -side right
pack $w.h.t -fill both
}
pack $w.f -fill both -expand 1
pack $w.f.y -fill y -side right
pack $w.f.t -fill both -expand 1 -side right
pack $w.status -fill y -side bottom
focus $w.f.t
body $id
}
sproc connect id {n username password w} {
set host [$w.hosts.listf.l get [$w.hosts.listf.l curselection]]
set n [nntp::nntp $host]
if {[info exists username] && [info exists password]} {
$n authinfo $user $password
}
uiswitch $id ui_groups
}
sproc groups_entry_update {id s} {w group} {
if {[set idx [$w.groups.listf.l curselection]] ne {}} {
set group [lindex [$w.groups.listf.l get $idx] 0]
uiswitch $id ui_group
}
}
sproc hosts_entry_update {id e} {host w} {
if {[set idx [$w.hosts.listf.l curselection]] ne {}} {
set host [lindex [$w.hosts.listf.l get $idx] 0]
uiswitch $id ui_authentication
}
}
sproc getgroups id {w} {
$w.groups.listf.l delete 0 end
$w.groups.listf.l insert 0 {retrieving groups...}
after idle [list getgroups2 $id]
}
sproc getgroups2 id {n w} {
$w.groups.listf.l delete 0 end
set max 20
foreach group [lsort [$n list]] {
set max [max [string length $group] $max]
$w.groups.listf.l insert end $group
}
$w.groups.listf.l selection set 0
$w.groups.listf.l configure -width $max
foreach sequence {<Double-Button-1> <Return>} {
bind $w.groups.listf.l $sequence [list groups_entry_update $id %T]
}
}
sproc messages id {body busy firstload from group lastgroup load loaded
loadnext n num to w} {
lassign [$n group $group] num from to group
if {$lastgroup ne $group} {
after cancel $busy
$w.x.l delete 0 end
set body [set loadnext [set loaded {}]]
set lastgroup $group
set load $firstload
set loadnext $to
}
gettingmessages $id
}
sproc gettingmessages id {
busy from group host load loaded loadnext n newcolor num to w} {
variable messages
if {[llength $loaded] >= $load || $loadnext == $from} {
$w.status configure -text {}
return
}
$w.status configure -text [list retrieving record $loadnext]
if {$loadnext ni $loaded && ![catch {set head [headfields [
$n head $loadnext]]}]} {
dict set messages $host $group $loadnext h $head
$w.x.l insert 0 [
list $loadnext [dict get $head Date] [
dict get $head Subject] [dict get $head From]]
$w.x.l itemconfigure [- [
$w.x.l index end] 1] -foreground $newcolor
if {[$w.x.l curselection] eq {}} {
$w.x.l selection set 0
}
$w.x.l see end
lappend loaded $loadnext
}
incr loadnext -1
set busy [after idle [list gettingmessages $id]]
}
sproc moremessages id {load loaded} {
set load [+ [llength $loaded] [entier [* [llength $loaded] .25]]
messages $id
}
sproc body id {body msg msgselection n w} {
if {[set msgselection [$w.x.l curselection]] ne {}} {
set msg [lindex [$w.x.l get $msgselection] 0]
$w.x.l itemconfigure $msgselection -foreground gray
set body [$n body $msg]
display $id
}
}
sproc nextmessage id {msgselection w} {
if {$msgselection >= [$w.x.l index end]} return
$w.x.l selection clear 0 end
$w.x.l selection set [incr msgselection]
body $id
}
sproc prevmessage id {msgselection w} {
if {$msgselection == 0} return
$w.x.l selection clear 0 end
$w.x.l selection set [incr msgselection -1]
body $id
}
proc cleansubject subject {
regsub -nocase {^[[:space:]]*re:[[:space:]]*} $subject {}
}
sproc threadmove {id direction} {w group host msg msgselection} {
variable messages
if {$direction > 0} {
set last [$w.x.l index end]
} else {
set last -1
}
set headers [dict get $messages $host $group $msg h]
set subject [cleansubject [dict get $headers Subject]]
if {[dict exists $headers References]} {
set related [split [dict get $headers References]]
}
set messageid [dict get $headers Message-ID]
lappend related $messageid
while {[set newselection [+ $msgselection [incr i $direction]]] != $last} {
set newmsg [lindex [$w.x.l get $newselection] 0]
set newheaders [dict get $messages $host $group $newmsg h]
if {[comparereference] || [comparesubject]} {
$w.x.l selection clear 0 end
$w.x.l selection set $newselection
body $id
break
}
}
}
proc comparesubject {} {
upvar newheaders newheaders subject subject
set newsubject [cleansubject [dict get $newheaders Subject]]
expr {[string first $subject $newsubject] >= 0 || [
string first $newsubject $subject] >= 0}
}
proc comparereference {} {
upvar newheaders newheaders related related
if {[dict exists $newheaders References]} {
set newreferences [split [dict get $newheaders References]]
}
lappend newreferences [dict get $newheaders Message-ID]
foreach reference $newreferences {
if {$reference in $related} {
return 1
}
}
return 0
}
sproc display id {body fromcolor group host msg replycolor subjectcolor w} {
variable messages
$w.h.t | delete 1.0 end
foreach {key val} [dict get $messages $host $group $msg h] {
set color [switch $key {
Subject {lindex $subjectcolor}
From {lindex $fromcolor}
default {lindex {}}
}]
$w.h.t | insert end $key $color
set color {}
$w.h.t | insert end { } {} $val\n
}
$w.h.t mark set insert 1.0
$w.f.t | delete 1.0 end
foreach line $body {
$w.f.t | insert end $line\n [
if {[string first > [string trim $line]] == 0} {
lindex $replycolor
}]
}
$w.f.t mark set insert 1.0
focus $w.f.t
}
#-- Extract a field from an article
proc get {what where} {
foreach line $where {
if [string match $what* $line] {
return [string map [list $what {}] $line]
}
}
}
proc headfields headers {
foreach header $headers {
set val [string trim [join [lassign [split $header :] key] :]]
lappend res $key $val
}
return $res
}
sproc goback id {winstack} {
lassign [lrange $winstack end-1 end] prev current
set winstack [lrange $winstack[set winstack {}] 0 end-2]
after idle [namespace code [list uiswitch $id $prev]]
}
proc pforget w {foreach window [winfo children $w] {pack forget $window}}
proc textwrapper w {
rename $w [set wrapped [info cmdcount]]
proc $w {arg1 args} [string map [list {{{wrapped}}} [list $wrapped]] {
if {[string tolower $arg1] eq {|}} {
return [{{wrapped}} {*}$args]
}
switch -exact $arg1 {
insert - delete - replace {}
default {
return [{{wrapped}} $arg1 {*}$args]
}
}
}]
return $wrapped
}
variable defaults {
hosts {
freenews.netfront.net
textnews.news.cambrium.nl
news.vsi.ru
news.grc.com
news.amu.edu.pl
}
deadhosts {
allnews.readfreenews.net
dp-news.maxwell.syr.edu
host aioe.cjb.net
freetext.usenetserver.com
news.f.de.plusline.net
news.readfreenews.net
pubnews.gradwell.net
w3bhost.de
}
group comp.lang.tcl
host textnews.news.cambrium.nl
lastgroup {}
firstload 64 loaded {}
fromcolor blue subjectcolor red readcolor gray newcolor blue
replycolor brown
sort threads
displayheaders 1
winstack exit
}
variable messages
bind . <F1> {console show}
wm attributes . -fullscreen 1
#wm geometry . [entier [winfo screenwidth .]]x[entier [winfo screenheight .]]
#wm geometry . 600x[entier [* [winfo screenheight .] .90]]
main $argv