Version 7 of Simple Newsreader
Updated 2004-03-22 13:02:40NEM 15Mar04 - I was recently working on code for a simple newsreader in Tcl/Tk, so that I could read comp.lang.tcl (didn't like any of the Mac newsreaders I downloaded). It's far from complete (you can't post yet), and not very well coded (little caching, doesn't reuse connections etc). However, as I'm unlikely to finish it off any time soon, I thought I'd dump the code up here to see if anyone else wants to finish it off, or use some of the code. See also A Snit News ticker widget, which I wrote a while ago, and which some of this code is based on. There is a reusable "article" widget in here, for displaying messages, which people may find useful. I'm planning on working that up into something better and submitting it to tklib.
Here's a screenshot of it looking all lovely on MacOS X:
Update - here is version 0.2. Quite a few improvements. The article widget has been factored out into a separate package, and now uses a canvas (and looks very nice, if I do say so myself ;). So, here's that file first (save it as article.tcl):
# Defines an "article" widget - for creating/displaying email
# messages/newsgroup posts etc. Probably needs a better name :)
package require Tcl 8.4
package require Tk 8.5
package require snit 0.91
package provide article 0.1
# Namespace... TODO
image create photo AquaPinstripe
# Create an image for the background
AquaPinstripe put {{#f3f3f3} {#f3f3f3} {#f6f6f6} {#f6f6f6}} -to 0 0 1000 200
snit::widgetadaptor rotext {
constructor {args} {
installhull using text -insertwidth 0
$self configurelist $args
}
method insert {args} {}
method delete {args} {}
delegate method Insert to hull as insert
delegate method Delete to hull as delete
delegate method * to hull
delegate option * to hull
}
# article --
#
# This widget is used for displaying/composing an article. It is basically a
# text widget, with some extra stuff at the top which displays headers - a
# title, and then some name/value pairs of headers.
snit::widget article {
option -headers [list]
option -headercolor #000000
option -headerfont {Helvetica 10}
# Width of header name field in pixels
option -headersize 70
delegate option -title to title as -text
delegate option -titlebackground to title as -background
delegate option -titlebg to title as -background
delegate option -titleforeground to title as -foreground
delegate option -titlefg to title as -foreground
delegate option -titlefont to title as -font
delegate option * to body
delegate method * to body
# Vars to hold fonts created for headers
variable hfont1
variable hfont2
constructor {args} {
frame $win.b
install body using rotext $win.b.body \
-yscrollcommand [list $win.b.vsb set]
scrollbar $win.b.vsb -orient vertical \
-command [list $win.b.body yview]
frame $win.h -borderwidth 2 -background black
canvas $win.h.c -borderwidth 0 -background black -height 50
$win.h.c create image 0 0 -anchor nw -image AquaPinstripe
# Create the title - this always exists
install title using label $win.h.title \
-anchor w -borderwidth 2 -padx 5
pack $win.h.title -fill x -expand 1
pack $win.h.c -fill both -expand 1 -padx 0 -pady 0
pack $win.h -fill x -side top -anchor n -padx 5 -pady 5
# Pack the text widget
pack $win.b.vsb -side right -fill y -anchor e
pack $win.b.body -side left -fill both -expand 1
pack $win.b -side bottom -fill both -expand 1
# Apply defaults for delegated options
$self configure -title "<no subject>"
$self configure -titlebackground #000066
$self configure -titleforeground #ffffff
$self configure -titlefont {Helvetica 10 bold}
# Set up header fonts
set hfont1 [font create -family Helvetica \
-size 10 -weight bold]
set hfont2 [font create -family Helvetica \
-size 10 -weight normal]
# Apply options passed at creation time
$self configurelist $args
}
destructor {
# Clean up fonts
font delete $hfont1
font delete $hfont2
}
onconfigure -headerfont {font} {
set options(-headerfont) $font
set opts [font actual $font]
eval [list font configure $hfont1] $opts [list -weight bold]
eval [list font configure $hfont2] $opts
}
onconfigure -headers {headers} {
# First - update the options array
set options(-headers) $headers
#catch {destroy $win.h.h}
#set top [frame $win.h.h]
# Now, create the widgets
set c $win.h.c
set ypos 5
set yheight [font metrics $hfont1 -displayof $win -linespace]
# Add a bit...
incr yheight 4
$c delete HeaderLabel HeaderValue
foreach {name value} $headers {
regsub {\s+} $name {_} wname
set wname [string tolower $wname]
set disp ${name}
while {[font measure $hfont1 -displayof $win $disp] >
$options(-headersize)} {
set disp [string range $disp 0 end-1]
}
$c create text $options(-headersize) $ypos \
-font $hfont1 \
-anchor ne -text ${disp}: -tags HeaderLabel
$c create text [expr {$options(-headersize)+5}] $ypos \
-font $hfont2 \
-anchor nw -text $value -tags HeaderValue
incr ypos $yheight
}
$c configure -height $ypos
}
}And here's the rest of the app (news.tcl) - Note this now uses tablelist rather than mclistbox:
# news.tcl --
#
# A NNTP newsreader written in Tcl/Tk. I got fed up looking for decent
# newsreaders, so I thought I'd write my own.
# I may add support for fancy things like RSS and threaded reading at some
# point.
#
# Copyright (c) 2004 Neil Madden.
# License: Tcl/BSD Style.
lappend auto_path /usr/local/lib
package require Tcl 8.4
package require Tk 8.4
package require snit 0.91
package require nntp
package require http
package require tablelist
source [file join [file dirname [info script]] article.tcl]
#lappend auto_path [file dirname [info script]]
package require article
set NEWSSERVER "localhost"
set NEWSPORT 119
#set USER "foo"
#set PASSWORD "sekret"
proc loadnews {} {
set news [list]
if {[file exists ~/.tclnews] && [file readable ~/.tclnews]} {
set fid [open ~/.tclnews]
set news [lsort -integer -index 0 [read $fid]]
close $fid
}
set nntp [nntp::nntp $::NEWSSERVER $::NEWSPORT]
if {[info exists ::USER]} {
$nntp authinfo $::USER $::PASSWORD
}
foreach {num first last} [$nntp group comp.lang.tcl] { break }
# Check headers to see whether there is new news...
set oldfirst [lindex $news 0 0]
set oldlast [lindex $news end 0]
if {$oldfirst eq ""} { set oldfirst 0 }
if {$oldlast eq "" } { set oldlast 0 }
if {$last > $oldlast} {
foreach item [$nntp xover [expr {$oldlast + 1}] $last] {
lappend news [split $item \t]
}
}
$nntp quit
# The following code is broken - removing until I come up with a proper fix.
#if {$first > $oldfirst} {
# set news [lrange $news [expr {$first - $oldfirst}] end]
#}
set fid [open ~/.tclnews w]
puts $fid $news
close $fid
return $news
}
proc updatepreview {} {
global art_body
set index [.main.l.list curselection]
if {![llength $index]} { return }
set index [lindex $index 0]
set headers [.main.l.list get $index]
foreach {id from subject date} $headers { break }
# This needs to display the actual group headers, but unfortunately XOVER
# doesn't seem to return them, so I'll have to move to a different method
# if I want them...
.main.body configure \
-headers [list From $from Date $date Groups comp.lang.tcl]
.main.body configure -title $subject
if {[info exists art_body($id)]} {
.main.body Delete 1.0 end
.main.body Insert end $art_body($id)
.main.body see 1.0
} else {
set nntp [nntp::nntp $::NEWSSERVER $::NEWSPORT]
if {[info exists ::USER]} {
$nntp authinfo $::USER $::PASSWORD
}
$nntp group comp.lang.tcl
set body [join [$nntp body $id] \n]
.main.body Delete 1.0 end
.main.body Insert end $body
.main.body see 1.0
$nntp quit
set art_body($id) $body
}
}
proc sortDate {item1 item2} {
return [expr {[clock scan $item1] - [clock scan $item2]}]
}
proc formatdate {secs} {
# Formats a the date as something nice:
# Today 23:08 (for posts made today)
# Yesterday 23:08 (posts yesterday, clearly)
# 19 March 2005 23:08 (all others)
set today [clock scan "today 00:00:00"]
set yesterday [clock scan "yesterday 00:00:00"]
if {$secs >= $today} {
return "Today [clock format $secs -format %H:%M:%S]"
} elseif {$secs >= $yesterday} {
return "Yesterday [clock format $secs -format %H:%M:%S]"
} else {
return [clock format $secs -format "%e %B %Y %H:%M:%S"]
}
}
proc main {argv} {
# Launch da code...
wm title . "Tk News Reader V0.2"
# Create some fonts
font create List -family {Lucida Grande} -size 12
font create ListHeader -family {Lucida Grande} -size 12 -weight bold
font create Body -family Optima -size 12
panedwindow .main -orient vertical
frame .main.l
tablelist::tablelist .main.l.list \
-columns {0 "Id"
0 "From"
0 "Subject"
0 "Date"} \
-labelcommand tablelist::sortByColumn \
-height 10 -width 80 -stretch all\
-xscrollcommand [list .main.l.hsb set] \
-yscrollcommand [list .main.l.vsb set] \
-background #f3f3f3 \
-stripebackground #e0e8f0 \
-selectbackground #000066 \
-selectforeground white \
-activestyle frame \
-selectmode single
bind .main.l.list <<ListboxSelect>> [list updatepreview]
.main.l.list columnconfigure 0 -hide 1
.main.l.list columnconfigure 1 -maxwidth 30
.main.l.list columnconfigure 2 -maxwidth 30
.main.l.list columnconfigure 3 -maxwidth 20 -sortmode command \
-sortcommand sortDate
scrollbar .main.l.vsb -command [list .main.l.list yview] -orient vertical
scrollbar .main.l.hsb -command [list .main.l.list xview] -orient horizontal
grid .main.l.list -column 0 -row 0 -sticky news
grid .main.l.vsb -column 1 -row 0 -sticky ns
grid .main.l.hsb -column 0 -row 1 -sticky ew
grid columnconfigure .main.l 0 -weight 1
grid rowconfigure .main.l 0 -weight 1
article .main.body \
-titlefont ListHeader \
-headerfont List \
-font Body \
-headers {From "" Subject "" Date ""} \
-height 10
.main add .main.l .main.body -sticky news
pack .main -fill both -expand 1
update
array set items {}
foreach item [loadnews] {
foreach {msgid subject from date idstring bodysize headersize xref} \
$item { break }
flush stdout
regexp {(.*)[\+\-](\d{4})} $date -> rest offset
if {[catch {clock scan $rest} secs]} {
puts "Skipping $date"
continue
}
set offset [string trimleft $offset 0]
regexp {0*(\d*)(\d\d)$} $offset -> hours mins
if {![string length $hours]} { set hours 0 }
incr secs [expr {$hours * 3600}]
incr secs [expr {$mins * 60}]
# Normalize the date
set date [formatdate $secs]
while {[info exists items($secs)]} {
incr secs
}
set items($secs) [list $msgid $from $subject $date]
}
foreach item [lsort -integer -decreasing [array names items]] {
.main.l.list insert end $items($item)
}
}
main $argv