'''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.
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 labelentry {id parent labeltext textvar bindings} {
    label $parent.label -text $labeltext
    entry $parent.entry -textvariable $textvar
    foreach {event action} $bindings {
        bind $parent.entry $event [list $action $id]
    }
    bind $parent.entry <Escape> [list goback $id]
}

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 activate 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 {
    variable data
    set id [info cmdcount]
    if {[llength $argv]} {
        lappend cmdargs path [lindex $argv 0]
    }
    lappend cmdargs w [set frame [frame .[info cmdcount]]]
    pack $frame -fill both -expand 1
    ui $id [namespace current]::defaults {*}$cmdargs
}

sproc ui {id statevar args} {busy deadhosts displayheaders firstload 
    from fromcolor group host hosts lastgroup lasthost load loaded messages
    n num username password newcolor seencolor replycolor status subjectcolor
    to w winstack} {
    variable $statevar
    dict with $statevar {dict with args {}}
    set busy [set lastgroup [set lasthost [set messages [set status {}]]]]
    set from [set to [set num {}]]
    set load $firstload

    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
            {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}
        {{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]

    scrolledlist $id [frame [frame $w.hosts].listf] $hosts $host [
        list hosts_entry_update $id]
    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]]
    }

    labelentry $id [frame [frame $w.authentication].username] username [
        namespace current]::state($id,username) {<Return> connect}
    labelentry $id [frame $w.authentication.password] password [
        namespace current]::state($id,password) {<Return> connect}
    $w.authentication.password.entry configure -show *

    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}}
    scrollbar [frame $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]

    scrollbar [frame $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 -textvariable [namespace current]::state($id,status)
    uiswitch $id ui_intro
}

sproc uiswitch {id next args} {w winstack} {
    lappend winstack $next
    pforget $w
    pack $w.status -side bottom -fill x
    $next $id {*}$args
}

sproc ui_intro id {w winstack} {
    pack $w.intro {*}[winfo children $w.intro]
    selection own $w.intro
    focus $w.intro.msg
}

sproc ui_hosts id {w winstack} {
    pack $w.hosts $w.hosts.listf -fill y -expand 1
    pack $w.hosts.listf.y -fill y -side right
    pack $w.hosts.listf.l -fill y -expand 1
    pack $w.hosts.entry -fill x
    focus $w.hosts.listf.l
    selection own $w.hosts.listf.l
    $w.hosts.listf.l selection set active
}

sproc ui_authentication id {w status winstack} {
    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
}

sproc ui_groups id w {
    pack $w.groups $w.groups.listf -fill y -expand 1
    pack $w.groups.listf.y -fill y -side right
    pack $w.groups.listf.l -fill y -expand 1
    pack $w.groups.entry -fill x
    if {[$w.groups.listf.l index end] > 1} {
        $w.groups.listf.l selection clear 0 end
        focus $w.groups.listf.l
        selection own $w.groups.listf.l
        $w.groups.listf.l selection set active
    } else {
        focus $w.groups.entry
        selection own $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
    $w.x.l selection clear 0 end
    $w.x.l selection set active
    focus $w.x.l
    group $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
    focus $w.f.t
    body $id
}

sproc connect id {host lasthost n username password status w} {
    set status Connecting...
    if {$lasthost ne $host} {
        if {[llength $host] == 1} {
            lappend host 119
        }
        set n [nntp::nntp {*}$host]
        if {$username ne {}} {
            $n authinfo $username $password
        }
        set lasthost $host
    }
    set status {}
    uiswitch $id ui_groups
}

sproc groups_entry_update id {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} {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 {n status w} {
    $w.groups.listf.l delete 0 end
    set status {Retrieving groups...}
    after idle [list getgroups2 $id]
}

sproc getgroups2 id {n status w} {
    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 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 groups_entry_update $id]
    }
    set status {}
}

sproc group id {body busy firstload from group lastgroup host lasthost
    load loaded loadnext messages n num to w} {
    variable data
    if {$lastgroup ne $group || $lasthost ne $host} {
        after cancel $busy
        if {$num ne {}} {
            dict set data h $host g $lastgroup m $messages
            set messages {}
            foreach varname {load loadnext num from to} {
                dict set data h $host g $lastgroup $varname [set $varname] 
                set $varname {}
            }
            $w.x.l delete 0 end
            set body [set loadnext [set loaded {}]]
        }
        lassign [$n group $group] num from to
        set load $firstload 
        set loadnext $to
        if {[dict exists $data h $host g $group m]} {
            set messages [dict get $data h $host g $group m]
            foreach varname {load} {
                set $varname [dict get $data h $host g $group $varname]
            }
        }
    }
    set lastgroup $group
    messages $id 
}

sproc messages id {busy from group host load loaded loadnext
    messages n newcolor num seencolor status to w} {
    if {[llength $loaded] >= $load || $loadnext == $from} {
        set status {}
        return
    } 
    set status [list $host $group [list retrieving record $loadnext]]
    if {$loadnext ni $loaded} {
        if {[dict exists $messages $loadnext h]} {
            set head [dict get $messages $loadnext h]
        } elseif {![catch {set head [headfields [$n head $loadnext]]}]} {
            dict set messages $loadnext h $head
        }
        if {[info exists head]} {
            set msgdict [dict get $messages $loadnext]
            $w.x.l insert 0 [
                list $loadnext [dict get $head Date] [
                dict get $head Subject] [dict get $head From]]
            if {[dict exists $messages $loadnext seen] && [
                dict get $messages $loadnext seen] == 1} {
                $w.x.l itemconfigure 0 -foreground $seencolor
            } else {
                $w.x.l itemconfigure 0 -foreground $newcolor
            }
            if {[$w.x.l index active] eq {}} {
                $w.x.l activate 0
            }
            $w.x.l see end
            lappend loaded $loadnext
        }
    }
    incr loadnext -1
    set busy [after idle [list messages $id]]
}

sproc moremessages id {load loaded} {
    set load [+ [llength $loaded] [entier [* [llength $loaded] .25]]]
    messages $id
}

sproc body id {body messages msg msgselection n seencolor w} {
    if {[set msgselection [$w.x.l index active]] ne {}} {
        set msg [lindex [$w.x.l get $msgselection] 0]
        dict set messages $msg seen 1
        $w.x.l itemconfigure $msgselection -foreground $seencolor 
        set body [$n body $msg]
        display $id 
    }
}

sproc nextmessage id {msgselection w} {
    if {$msgselection >= [$w.x.l index end]} return 
    $w.x.l activate [incr msgselection]
    body $id
}

sproc prevmessage id {msgselection w} {
    if {$msgselection == 0} return 
    $w.x.l activate [incr msgselection -1]
    body $id
}

proc cleansubject subject {
    regsub -nocase {^[[:space:]]*re:[[:space:]]*} $subject {}
}


sproc threadmove {id direction} {w group host messages msg msgselection} {
    if {$direction > 0} {
        set last [$w.x.l index end]
    } else {
        set last -1
    }
    set headers [dict get $messages $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 $newmsg h]
        if {[comparereference] || [comparesubject]} {
            $w.x.l activate $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 messages msg replycolor
    subjectcolor w} {
    $w.h.t | delete 1.0 end
    foreach {key val} [dict get $messages $msg h] {
        set color [switch $key {
            Subject {lindex $subjectcolor}
            From {lindex $fromcolor}
            default {lindex {}}
        }]
        $w.h.t | insert end $key $color { } {} $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
}

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

sproc myexit id {group} {
    set group {}
    group $id
    save $id
    exit 
}

sproc load {id path} {} {
    path $path
    variable data
    set chan [open $path/data]
    close $chan[set data [read $chan]]
}

sproc save id {} {
    variable argv
    variable data
    set path [lindex $argv 0]
    if {![file exists $path]} {
        while {[file exists $path/[set uniq [clock clicks]]]} {} 
        file mkdir $path/$uniq
        rename $path/$uniq $path
        file delete -force $path/$uniq
    }
    set chan [open [lindex $argv 0] w]
    close $chan[puts $chan $data]
}

proc headfields headers {
    foreach header $headers {
        set val [string trim [join [lassign [split $header :] key] :]]
        lappend res $key $val
    }
    return $res
}


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 {
        {aioe.cjb.net 119}
        {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}
    }
    deadhosts {
        {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
    replycolor brown
    sort threads
    displayheaders 1
    winstack myexit
}

variable data {}

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