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 to post messages. 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 foreach package {Tk mime nntp} { package require $package } namespace import ::tcl::mathfunc::* namespace import ::tcl::mathop::* namespace export * proc activatev {listbox val} { set i 0 foreach item [$listbox get 0 end] { if {$item eq $val} { $listbox activate $i return } } error [list {not found} $item] } proc cleansubject subject { regsub -nocase {^[[:space:]]*re:[[:space:]]*} $subject {} } proc comparesubject {newheaders subject} { set newsubject [cleansubject [dict get $newheaders Subject]] expr {[string first $subject $newsubject] >= 0 || [ string first $newsubject $subject] >= 0} } proc comparereference {newheaders 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 } proc headfields headers { foreach header $headers { set val [string trim [join [lassign [split $header :] key] :]] lappend res $key $val } return $res } proc main argv { variable defaults if {[llength $argv]} { lappend cmdargs path [lindex $argv 0] } lappend cmdargs w [set frame [frame .[info cmdcount]]] pack $frame -fill both -expand 1 set reader [reader] set ${reader}::defaults defaults $reader init $defaults {*}$cmdargs $reader ui $reader go } proc pforget w {foreach window [winfo children $w] {pack forget $window}} proc labelentry {parent labeltext textvar bindings} { label $parent.label -text $labeltext entry $parent.entry -textvariable $textvar foreach {event action} $bindings { bind $parent.entry $event $action } } proc labelfocusconfig path { bind $path <FocusIn> [list $path configure -fg blue] bind $path <FocusOut> [list $path configure -fg [ lindex [$path configure -fg] 3]] } proc labelitem {path text command} { label $path -takefocus 1 -text $text labelfocusconfig $path bind $path <Double-Button-1> $command bind $path <Return> $command bind $path <Down> [list event generate $path <Tab>] bind $path <Up> [list event generate $path <Shift-Tab>] } proc listboxentry {path entrytextvar entrybinding} { listbox [frame $path.listf].l scrolled $path.listf.l y entry $path.entry -textvar $entrytextvar foreach sequence {<Double-Button-1> <Return>} { bind $path.entry $sequence [namespace code $entrybinding] } } proc packlistbox path { pack $path -fill both -expand 1 pack $path.y -fill y -side right pack $path.l -fill both -expand 1 $path.l selection clear 0 end focus $path.l selection own $path.l $path.l selection set active } proc packlistboxentry path { pack $path -fill both -expand 1 packlistbox $path.listf pack $path.entry -fill x if {[$path.listf.l index end] == 0} { focus $path.entry selection own $path.entry } } proc reader args { if {[llength $args]} { set args [lassign $args id] } else { set id [info cmdcount] } object $id } proc scrolled {widget dim} { set parent [winfo parent $widget] foreach dim1 $dim { scrollbar $parent.$dim1 -command [list $widget yview] $widget configure -${dim1}scrollc [list $parent.$dim1 set] } return $widget } 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 } proc object id { if {[string first :: $id] != 0} { set id [string trimright [uplevel namespace current] :]::$id } namespace eval $id { namespace ensemble create namespace export -clear namespace ensemble configure [namespace current] -unknown [ list apply [list args { return [lindex $args 0]::[lindex $args 1] } [namespace current]] ] } namespace eval $id [list namespace import [namespace current]::*] return $id } proc method {name argspec attributes body} { set script [string map [list {{{attributes}}} [list $attributes]] { set id [namespace qualifiers [lindex [info level 0] 0]] foreach varname [set attributes {{attributes}}] { upvar 0 ${id}::$varname $varname } }] proc $name $argspec $script$body } method body {} {host group body msg msgselection n seencolor w} { if {[set msgselection [$w.group.l index active]] ne {}} { set msg [lindex [$w.group.l get $msgselection] 0] $id ds h $host g $group m $msg seen 1 $w.group.l itemconfigure $msgselection -foreground $seencolor set body [$n body $msg] } } method composedone {} {w} { $w.compose.text } method composesave {} {w} { set text [$w.compose.text get 1.0 end] } method connect {} {data host lasthost n username password status w} { $id ds h $host username $username $id ds h $host password $password set status Connecting... set failed 0 if {$n eq {} || $lasthost ne $host} { if {[llength $host] == 1} { lappend host 119 } set n [nntp::nntp {*}$host] #issue one command to make sure the server dosn't time out if {$username ne {}} { if {[catch {$n authinfo $username $password} cres copts]} { $n quit set n {} if {[lindex $cres 1] eq {501}} { set status $cres return } else { return -options $copts $cres } } } set lasthost $host $n date } set status {} $id uido ui_groups } method d args data { dict get $data {*}$args } method d? args data { dict exists $data {*}$args } method dk args data { set dict [dict get $data {*}[lrange $args 0 end-1]] dict keys $dict [lindex $args -1] } method ds args data { dict set data {*}$args } method display {} {body fromcolor group host msg replycolor subjectcolor w} { $w.msgh.t | delete 1.0 end foreach {key val} [$id d h $host g $group m $msg h] { set color [switch $key { Subject {lindex $subjectcolor} From {lindex $fromcolor} default {lindex {}} }] $w.msgh.t | insert end $key $color { } {} $val\n } $w.msgh.t mark set insert 1.0 $w.msg.t | delete 1.0 end foreach line $body { $w.msg.t | insert end $line\n [ if {[string first > [string trim $line]] == 0} { lindex $replycolor }] } $w.msg.t mark set insert 1.0 focus $w.msg.t } method groups_entry_update {} {w group} { if {[set idx [$w.groups.listf.l curselection]] ne {}} { set group [lindex [$w.groups.listf.l get $idx] 0] $id uido ui_group } } method getgroups {} {n status w} { $w.groups.listf.l delete 0 end after idle [list $id getgroups2] } method getgroups2 {} n { $id populategroups [lsort [$n list]] } method go {} {data w} { $id uido ui_intro } method goback {} winstack { lassign [lrange $winstack end-1 end] prev current set winstack [lrange $winstack[set winstack {}] 0 end-2] after idle [namespace code [list $id uido $prev]] } method group {} {body busy data firstload group lastgroup host lasthost load loaded loadnext msgfirst msglast n num w} { if {$num eq {}} { } else { after cancel $busy } if {$lastgroup ne $group || $lasthost ne $host} { if {$num ne {}} { foreach varname {load loadnext num msgfirst msglast} { $id ds h $host g $lastgroup $varname [set $varname] set $varname {} } $w.group.l delete 0 end set body [set loadnext [set loaded {}]] } if {$group ne {}} { lassign [$n group $group] num msgfirst msglast set load $firstload set loadnext $msglast if {[$id d? h $host g $group m]} { set zub [$id d h $host g $group] foreach varname load { set $varname [$id d h $host g $group $varname] } } } } set lastgroup $group if {$group ne {}} { $id messages } } method header_entry_update path {w group} { if {[set idx [$w.headers.listf.l curselection]] ne {}} { set header [$w.header.listf.l get $idx] } switch $path $w.headers.listf.l { set ${id}::header $val [$id d headers $header $val] } $w.headers.entry { $id ds headers $header [$w.headers.entry get] } } method hosts_entry_update {} {host w} { if {[set idx [$w.hosts.listf.l curselection]] ne {}} { set host [$w.hosts.listf.l get $idx] $id uido ui_authentication } } variable attributes { busy data deadhosts displayheaders firstload fromcolor group groups host hosts lastgroup lasthost lbwidth load loaded loadnext msgfirst msglast n newcolor blanksubject num password path port replycolor seencolor setting status subject subjectcolor username w winstack } method authentication {} {host password username w} { if {![$id d? h $host]} { $id ds h $host groups {} $id ds h $host username {} $id ds h $host password {} } set username [$id d h $host username] set password [$id d h $host password] } method init {defaults args} $attributes { variable headers #attributes is provided by the "method" proc foreach varname $attributes {set $varname {}} dict with defaults {dict with args {}} set blanksubject -1 foreach {key val} $headers { foreach val $val { $id ds headers $val {} } } if {[info exists path] && [file exists $path/data]} { $id load if {[$id d? attributes]} { dict for {key val} [$id d attributes] { set ${id}::$key $val } } } set load $firstload } method initwindow w {} { $id keys_common $w } method keys_common w {} { #these may be set on an entry widget, so are limited to non-entry keys bind $w <Escape> [namespace code [list $id goback]] bind $w <Control-`> [namespace code [list uido ui_settings]] return $w } method lbconfig {path data activated updater} lbwidth { set max $lbwidth foreach data1 $data { $path insert end $data1 set max [max [string length $data1] $max] if {$activated eq $data1} { $path activate end } } $path configure -width $max foreach sequence {<Double-Button-1> <Return>} { bind $path $sequence [namespace code $updater] } return $path } method mylistboxentry {path entryvarname entrybinding} {} { listboxentry $path $entryvarname $entrybinding $id keys_common $path.listf.l $id keys_common $path.entry } method load {} {data path} { set data [read [set chan [open $path/data]]][close $chan] } method messages {} {busy group host load loaded loadnext n msgfirst msglast newcolor num seencolor status w} { if {[llength $loaded] >= $load || $loadnext == $msgfirst} { set status {} return } set status [list $host $group [list retrieving record $loadnext]] if {$loadnext ni $loaded} { if {[$id d? h $host g $group m $loadnext h]} { set head [$id d h $host g $group m $loadnext h] } elseif {![catch {set head [headfields [$n head $loadnext]]}]} { $id ds h $host g $group m $loadnext h $head } if {[info exists head]} { set msgdict [$id d h $host g $group m $loadnext] $w.group.l insert 0 [ list $loadnext [dict get $head Date] [ dict get $head Subject] [dict get $head From]] if {[dict exists $msgdict $loadnext seen] && [ dict get $messages $loadnext seen] == 1} { $w.group.l itemconfigure 0 -foreground $seencolor } else { $w.group.l itemconfigure 0 -foreground $newcolor } if {[$w.group.l index active] eq {}} { $w.group.l activate 0 } $w.group.l see end lappend loaded $loadnext } } incr loadnext -1 set busy [after idle [list $id messages]] } method moremessages {} {load loaded} { set load [+ [llength $loaded] [entier [* [llength $loaded] .25]]] $id messages } method myexit {} {group n path} { if {$n ne {}} { set group {} $id group } if {[info exists path]} { $id save } exit } method nextmessage {} {msgselection w} { if {$msgselection >= [$w.group.l index end]} return $w.group.l activate [incr msgselection] $id ui_message } method populategroups groups {data host lbwidth status w} { set max $lbwidth foreach group $groups { set max [max [string length $group] $max] $w.groups.listf.l insert end $group lappend groups $group } $id ds h $host groups $groups $w.groups.listf.l activate 0 if {[string first $w.groups [selection own]] == 0} { $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 $id groups_entry_update] } set status {} } method prevmessage {} {msgselection w} { if {$msgselection == 0} return $w.group.l activate [incr msgselection -1] $id ui_message $id display } method save {} {data path} { upvar 0 [namespace current]::attributes myattributes foreach myattribute $myattributes { if {$myattribute ni {busy n w}} { $id ds attributes $myattribute [set ${id}::$myattribute] } } if {![file exists $path]} { file mkdir $path } while {[file exists $path/[set uniq [clock clicks]]]} {} file mkdir $path/$uniq set chan [open $path/$uniq/data w] close $chan[puts $chan $data] file rename -force $path/$uniq/data $path/data file delete -force $path/$uniq } method send {} {blanksubject n status subject w} { if {$subject eq {}} { if {$blanksubject == -1} { after idle [list $id uido ui_blanksubject] return } elseif {$blanksubject == 0} { after idle [list $id uido ui_subject] return } } set body [$w.compose.text get 1.0 end] set bodypart [mime::initialize -canonical text/plain -string $body] set token [::mime::initialize -canonical multipart/mixed -parts [ list $bodypart]] foreach {key val} [$id d headers] { ::mime::setheader $token $key $val } set status {Sent!} set blanksubject -1 after idle [list $id goback] } method setback {varname value} {} { set ${id}::$varname $value $id goback } #forward back next prev first last method threadmove mode {w group host msg msgselection} { switch $mode { forward - next - last { set direction 1 set last [$w.group.l index end] } back - prev - first { set direction -1 set last -1 } } set headers [$id d h $host g $group m $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 set found 0 while {[set newselection [+ $msgselection [incr i $direction]]] != $last} { set newmsg [lindex [$w.group.l get $newselection] 0] set newheaders [$id d h $host g $group m $newmsg h] switch $mode { forward - back { if {[comparereference $newheaders $related] || [ comparesubject $newheaders $subject]} { set found 1 break } } next - prev - first - last { if {![comparereference $newheaders $related] && ![ comparesubject $newheaders $subject]} { switch $mode { next { set found 1 break } prev { $w.group.l activate $newselection $id body tailcall $id threadmove first } first - last { set found 1 incr newselection [* $direction -1] break } } } continue } } } if {$found} { $w.group.l activate $newselection $id ui_message } } method ui {} {data fromcolor headers host hosts replycolor subjectcolor w} { text [frame $w.intro].msg foreach phrase { {{A little NNTP Reader} bold \n\n} {Invocation: bold \n\n} {programname overstrike { dirname} italic \n} {{dirname} italic { is the name of a directory that can be used exclusively by the program for data storage } {} \n} {Authentication bold \n\n} {{Leave username field blank for an anonynomous session} {} \n\n} {{General Keys:} bold \n\n} {{Escape {return to previous screen}} {} \n} {{Return continue} {} \n\n} {{Message List Keys:} bold \n\n} {{c {compose new message}} {} \n} {{m {load more messages}} {} \n\n} {{Message Keys:} bold \n\n} {{h {view headers}} {} \n} {{n {next mesage}} {} \n} {{N {next thread}} {} \n} {{p {previous mesage}} {} \n} {{P {previous thread}} {} \n} {{b {backward in thread}} {} \n} {{B {beginning of thread}} {} \n} {{f {forward in thread}} {} \n} {{F {end of thread}} {} \n} {\n {} {Compose Keys:} bold \n\n} {{Control-d done (send)} {} \n} {{Control-f from} {} \n} {{Control-h manage headers} {} \n} {{Control-s subject} {} \n} } { $w.intro.msg insert end {*}$phrase } $w.intro.msg mark set insert 1.0 $w.intro.msg tag configure bold -font bold $id keys_common $w.intro.msg bind $w.intro.msg <Return> [list $id uido ui_hosts] textwrapper $w.intro.msg $id mylistboxentry [frame $w.hosts] ${id}::host [ list uido $id ui_authentication] $id lbconfig $w.hosts.listf.l $hosts $host [list $id hosts_entry_update] labelentry [frame [frame $w.authentication].username] username \ ${id}::username [list <Return> [list $id connect]] $id keys_common $w.authentication.username.entry labelentry [frame $w.authentication.password] \ password ${id}::password [list <Return> [list $id connect]] $id keys_common $w.authentication.password.entry $w.authentication.password.entry configure -show * $id mylistboxentry [frame $w.groups] ${id}::group [list $id uido ui_group] $id lbconfig $w.groups.listf.l {} {} [list $id getgroups] scrolled [$id lbconfig [listbox [frame $w.group].l] {} {} [ list $id uido ui_message]] y $id keys_common $w.group.l bind $w.group.l m [list $id moremessages] bind $w.group.l c [list $id uistack ui_compose ui_subject [ list ui_setting From]] set textopts {-wrap word -padx 5 -pady 3 -height 12 -font {Helvetica 9}} foreach i {msgh msg} { scrolled [text [frame $w.$i].t {*}$textopts] y textwrapper $w.$i.t foreach color [list $fromcolor $replycolor $subjectcolor] { $w.$i.t tag configure $color -foreground $color } } $id keys_common $w.msg.t bind $w.msg.t h [list $id uido ui_header] bind $w.msg.t n [list $id nextmessage] bind $w.msg.t p [list $id prevmessage] bind $w.msg.t b [list $id threadmove back] bind $w.msg.t f [list $id threadmove forward] bind $w.msg.t B [list $id threadmove first] bind $w.msg.t F [list $id threadmove last] bind $w.msg.t N [list $id threadmove next] bind $w.msg.t P [list $id threadmove prev] labelentry [frame $w.subject] subject ${id}::subject [ list <Return> [list $id goback]] $id keys_common $w.subject.entry label [frame $w.blanksubject].label -text {Leave subject blank?} labelitem $w.blanksubject.no no [list $id setback blanksubject 0] labelitem $w.blanksubject.yes yes [list $id setback blanksubject 1] scrolled [text [frame $w.compose].text] y $id keys_common $w.compose.text bind $w.compose.text <Control-d> [list $id composedone] bind $w.compose.text <Control-f> [list $id uido [list ui_setting from]] bind $w.compose.text <Control-h> [list $id uido [list ui_headers]] bind $w.compose.text <Control-s> [list $id uido ui_subject] $id mylistboxentry [frame $w.headers] ${id}::header [ list uido $id header_entry_update %W] $id lbconfig $w.headers.listf.l {} {} [list $id uido header_entry_update %W] scrolled [$id lbconfig [listbox [frame [frame $w.settings].listf].l] { from } {} [list <Return> [list $id uido ui_setting]]] y $id keys_common $w.settings.listf.l labelentry [frame $w.setting] {} ${id}::setting [ list <Return> [list $id update_setting]] $id keys_common $w.setting.entry label $w.status -textvariable ${id}::status } method ui_authentication {} {w status winstack} { $id authentication set status {} pack $w.authentication {*}[winfo children $w.authentication] {*}[ winfo children $w.authentication.username] {*}[ winfo children $w.authentication.password] focus $w.authentication.username.entry selection own $w.authentication.username.entry } method ui_blanksubject {} w { pack $w.blanksubject {*}[winfo children $w.blanksubject] focus $w.blanksubject.no } method ui_compose {} {from blanksubject subject w} { pack $w.compose $w.compose.text -fill both -expand 1 focus $w.compose.text } method ui_groups {} {host data host status w} { if {[$w.groups.listf.l index end] == 0} { if {[$id d h $host groups] eq {}} { $w.groups.listf.l insert end {double-click to load groups} set cmd ui_groups3 } else { set status {loading saved groups...} set cmd ui_groups2 } bind $w.groups.listf.l <Configure> [list $id $cmd] } packlistboxentry $w.groups } method ui_groups2 {} {host} { $id populategroups [$id d h $host groups] after idle [list $id ui_groups3] } method ui_groups3 {} {data host status w} { packlistboxentry $w.groups bind $w.groups.listf.l <Configure> {} set status {} } method ui_group {} w { packlistbox $w.group $id group } method ui_header {} {displayheaders w winstack} { set displayheaders [! $displayheaders] $id goback } method ui_headers {} {w} { packlistboxentry $w.headers } method ui_hosts {} w { packlistboxentry $w.hosts } method ui_intro {} {w winstack} { pack $w.intro {*}[winfo children $w.intro] -fill both -expand 1 selection own $w.intro focus $w.intro.msg } method ui_message {} {displayheaders w} { if {$displayheaders} { pack $w.msgh -fill both pack $w.msgh.y -fill y -side right pack $w.msgh.t -fill both } pack $w.msg -fill both -expand 1 pack $w.msg.y -fill y -side right pack $w.msg.t -fill both -expand 1 -side right focus $w.msg.t $id body $id display } method ui_send {} {status} { set status Connecting... $id send } method ui_setting setting w { $w.setting.label configure -text $setting pack $w.setting $w.setting.label $w.setting.entry focus $w.setting.entry } method ui_setting_active {} w { $id ui_setting [$w.settings.listf.l get active] } method ui_settings {} w { packlistbox $w.settings.listf } method ui_subject {} {blanksubject w} { set blanksubject -1 pack $w.subject {*}[winfo children $w.subject] focus $w.subject.entry } method uido args {w winstack} { $id uipush $args pforget $w pack $w.status -side bottom -fill x $id {*}$args } method uipush {args} {winstack} { lappend winstack $args } method uistack args winstack { set args [lreverse [lassign [lreverse $args[set args {}]] last]] foreach arg $args { lappend winstack $arg } $id uido {*}$last } method update_setting {} w { set setting [$w.settings.listf.l get active] if {$setting eq {}} { error [list {no setting active}] } set val [$w.setting.entry get] set ${id}::$setting $val $id goback } variable defaults { hosts { {freenews.netfront.net 119} {textnews.news.cambrium.nl 119} {news.vsi.ru 119} {news.grc.com 119} {news.amu.edu.pl 119} {news.eternal-september.org 119} {news.eternal-september.org 563} {nntp.aioe.org 119} {reader.albasani.net 119} {medium.com 119} } deadhosts { {aioe.cjb.net 119} {allnews.readfreenews.net 119} {dp-news.maxwell.syr.edu 119} {freetext.usenetserver.com 119} {news.f.de.plusline.net 119} {news.readfreenews.net 119} {pubnews.gradwell.net 119} {w3bhost.de 119} } group comp.lang.tcl host textnews.news.cambrium.nl firstload 64 loaded {} fromcolor blue subjectcolor red seencolor gray newcolor blue lbwidth 20 replycolor brown sort threads displayheaders 1 winstack myexit } variable headers { mandatory {From Date Newsgroups Subject Message-ID Path} optional {Followup-To Expires Reply-To Sender References Control Distribution Keywords Summary Approved Lines Xref Organization} custom { } } 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