'''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]



** Code **

======
#! /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
======

<<categories>> NNTP