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



** Features **

   * filesystem-backed

   * navigate threads (forward in thread, back in thread, first in thread, last in thread, previous thread, next thread)



** Code **

======
#! /bin/env tclsh

package require Tk
package require mime
package require nntp
namespace import ::tcl::mathfunc::*
namespace import ::tcl::mathop::*
namespace export *

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
}

proc reader args {
    if {[llength $args]} {
        set args [lassign $args id]
    } else {
        set id [info cmdcount]
    }
    object $id
}

method init {defaults args} {busy deadhosts data displayheaders firstload 
    lbwidth msgfirst msglast fromcolor group host hosts lastgroup lasthost load
    loaded messages n num username path password newcolor seencolor
    replycolor status subjectcolor w winstack} {
    dict with defaults {dict with args {}}
    set busy [set lastgroup [set lasthost [set messages [set status {}]]]]
    set msgfirst [set msglast [set num {}]]
    if {[info exists path] && [file exists $path/data]} {
        $id load
        if {[dict exists $data defaults]} {
            set saveddefaults [dict get $data defaults]
            dict with saveddefaults {}
        }
    }
    set load $firstload
}

method ui {} {fromcolor replycolor group host hosts 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}
        {{n {new post}} {} \n}
        {{m {load more post}} {} \n\n}
        {{Message Keys:} bold \n\n}
        {{h {view headers}} {} \n} 
        {{n {next post}} {} \n}
        {{N {next thread}} {} \n}
        {{p {previous post}} {} \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}
        {{Post Keys:} bold \n\n}
        {s {send} {} \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 uiswitch ui_hosts]
    textwrapper $w.intro.msg

    listbox [frame [frame $w.hosts].listf].l
    $id lbconfig $w.hosts.listf.l $hosts $host [list $id hosts_entry_update]
    scrolled $w.hosts.listf.l y
    $id keys_common $w.hosts.listf.l
    entry $w.hosts.entry -textvar ${id}::host
    $id keys_common $w.hosts.entry
    foreach sequence {<Double-Button-1> <Return>} {
        bind $w.hosts.entry $sequence [
            namespace code [list uiswitch $id ui_authentication]]
    }

    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 *

    set groupsmsg {{double-click to load groups}}
    scrolled [$id lbconfig [listbox [frame [frame $w.groups].listf].l] \
        $groupsmsg $group [list $id getgroups]] y
    $id keys_common $w.groups.listf.l
    $w.groups.listf.l configure -width [string length $groupsmsg]
    entry $w.groups.entry -textvariable ${id}::group
    bind $w.groups.entry <Return> [list $id uiswitch ui_group]
    $id keys_common $w.groups.entry

    scrolled [$id lbconfig [listbox [frame $w.x].l] {} {} [
        list $id uiswitch ui_message]] y
    $id keys_common $w.x.l
    bind $w.x.l m [list $id moremessages] 
    bind $w.x.l n [list $id uiswitch ui_post] 

    set textopts {-wrap word -padx 5 -pady 3 -height 12 -font {Helvetica 9}}
    scrolled [text [frame $w.h].t {*}$textopts] y
    textwrapper $w.h.t
    foreach color [list $fromcolor $replycolor $subjectcolor] {
        $w.h.t tag configure $color -foreground $color
    }
    bind $w.h.t h [list $id ui_header]

    scrolled [text [frame $w.f].t {*}$textopts] y
    textwrapper $w.f.t
    foreach color [list $fromcolor $replycolor $subjectcolor] {
        $w.f.t tag configure $color -foreground $color
    }
    $id keys_common $w.f.t
    bind $w.f.t h [list $id ui_header]
    bind $w.f.t n [list $id nextmessage] 
    bind $w.f.t p [list $id prevmessage] 
    bind $w.f.t b [list $id threadmove back] 
    bind $w.f.t f [list $id threadmove forward] 
    bind $w.f.t B [list $id threadmove first] 
    bind $w.f.t F [list $id threadmove last] 
    bind $w.f.t N [list $id threadmove next] 
    bind $w.f.t P [list $id threadmove prev] 

    scrolled [text [frame $w.post].text] y
    bind $w.post.text s [list $id send]
    
    scrolled [$id lbconfig [listbox [frame [frame $w.settings].listf].l] {
        from
    } {} [list $id uiswitch ui_setting]] y

    labelentry [frame $w.setting] {} ${id}::setting [
        list $id update_setting]

    label $w.status -textvariable ${id}::status
    $id uiswitch ui_intro
}

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

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

method ui_authentication {} {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
}

method ui_groups {} 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
    }
}

method ui_group {} 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
    $id group
}

method ui_header {} {displayheaders w} {
    set displayheaders [! $displayheaders]
    $id uiswitch ui_message
}

method ui_message {} {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
    $id body
    $id display
}

method ui_post {} {w} {
    pack $w.post $w.post.text -fill both -expand 1
}

method ui_setting {} {} {
    pack $w.setting.entry
}

method ui_settings {} {} {
    pack $w.settings $w.settings.lisft -fill y -expand 1
    pack $w.settings.listf.y -fill y -side right
    pack $w.settings.listf.l -fill y -expand 1
}

method connect {} {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 {}
    $id uiswitch ui_groups
}

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 uiswitch ui_group 
    }
}

method hosts_entry_update {} {host w} {
    if {[set idx [$w.hosts.listf.l curselection]] ne {}} {
        set host [lindex [$w.hosts.listf.l get $idx] 0]
        $id uiswitch ui_authentication
    }
}

method getgroups {} {n status w} {
    $w.groups.listf.l delete 0 end
    set status {Retrieving groups...}
    after idle [list $id getgroups2]
}

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

method group {} {body busy data firstload group lastgroup host lasthost
    load loaded loadnext messages msgfirst msglast n num w} {
    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 msgfirst msglast} {
                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 msgfirst msglast
        set load $firstload 
        set loadnext $msglast
        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
    $id messages
}

method messages {} {busy group host load loaded loadnext messages 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 {[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 $id messages]]
}

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

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

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

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

#forward back next prev first last
method threadmove mode {w group host messages msg msgselection} {
    switch $mode {
        forward - next - last {
            set direction 1
            set last [$w.x.l index end]
        }
        back - prev - first {
            set direction -1
            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

    set found 0
    while {[set newselection [+ $msgselection [incr i $direction]]] != $last} {
        set newmsg [lindex [$w.x.l get $newselection] 0]
        set newheaders [dict get $messages $newmsg h]
        switch $mode {
            forward - back {
                if {[comparereference] || [comparesubject]} {
                    set found 1
                    break
                }
            }
            next - prev - first - last {
                if {![comparereference] && ![comparesubject]} {
                    switch $mode {
                        next {
                            set found 1
                            break
                        }
                        prev {
                            $w.x.l activate $newselection 
                            $id body
                            tailcall $id threadmove first
                        }
                        first - last {
                            set found 1
                            incr newselection [* $direction -1]
                            break
                        }
                    }
                }
                continue
            }
        }
    }
    if {$found} {
        $w.x.l activate $newselection
        $id ui_message
    }
}

method display {} {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
}

method goback {} winstack {
    lassign [lrange $winstack end-1 end] prev current
    puts "yuck: .. $prev"
    set winstack [lrange $winstack[set winstack {}] 0 end-2]
    after idle [namespace code [list $id uiswitch $prev]]
}

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 uiswitch ui_settings]]
    return $w
}

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


method load {} {data path} {
    set chan [open $path/data]
    set data [read $chan]
    close $chan
}

method myexit {} {group n path} {
    if {[info exists n]} {
        set group {}
        $id group
    }
    if {[info exists path]} {
        $id save
    }
    exit 
}

method save {} {data path} {
    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 {} {n w} {
    set body [$w.post.text get]
    set token [::mime::initialize -canonical text/plain]
    ::mime::setheader $token
}


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

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
}

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

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
}

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
}

proc pforget w {foreach window [winfo children $w] {pack forget $window}}

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
}

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

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