NEM - A little fun project to create a news/stock ticker widget, and here's the result. I used Snit's Not Incr Tcl to make it act like a real Tk widget, but it's pure Tk code apart from that. Basically, the widget is a single line display (like a label), which you can add messages to. The messages scroll across the widget one after the other in order. You can click on a message and a procedure will be run, so you could have the messages as articles from slashdot and the procedure would launch a browser to the appropriate page.
There are a couple of bugs with the implementation, but it's good enough for my purposes. The main bug is that if you resize the widget (making it smaller) then the items can screw up and become overlapped. You can workaround by deleting all items and then re-adding them on a resize, but a real fix would be better.
(Update - I think I've fixed most of the bugs now and it seems pretty useable).
Anyway - the package (need's Tcl 8.4 as I use lset):
# Defines a snit widget type for a ticker.
package provide ticker 0.1
package require Tcl 8.4
package require Tk
package require snit 0.91
snit::widgetadaptor ticker {
option -scrollstep -2
option -scrollinterval 20
option -font {Helvetica 12 bold}
variable event ""
variable items [list]
variable newitems [list]
variable messagelength 0
constructor {args} {
#component hull is [canvas $self]
installhull using canvas
$self configurelist $args
set height [font metrics $options(-font) -linespace]
$self configure -height [expr {$height + 4}]
# Add mouse-wheel bindings
switch $::tcl_platform(platform) {
unix {
bind $self <Button-4> [list $self scroll 20]
bind $self <Button-5> [list $self scroll -20]
}
}
$self resume
}
method scroll {amount} {
set save $options(-scrollstep)
set options(-scrollstep) $amount
$self Scroll
set options(-scrollstep) $save
}
method dummy {args} {}
method add {text command} {
# Append a new item to the ticker, and register a callback on it
set id [$self create text 2000 2 -anchor nw -text $text \
-fill #efeb90 -font $options(-font)]
$self bind $id <Enter> [list $self Enter $id]
$self bind $id <Leave> [list $self Leave $id]
$self bind $id <ButtonPress-1> [concat $command $id]
set width [font measure $options(-font) $text]
if {![llength $items]} {
set insertpos [winfo width $self]
}
lappend newitems $id $width
return $id
}
method remove {id} {
if {$id eq "all"} {
foreach {i _ _} $items {
$self delete $i
}
set items [list]
} elseif {[set idx [lsearch $items $id]] != -1} {
$self delete $id
set width [lindex $items [expr {$idx + 1}]]
set items [lreplace $items $idx [expr {$idx + 2}]]
incr messagelength -$width
incr messagelength -20
# We need to adjust the position of all items after this one:
for {set i [expr {$idx + 2}]} {$i < [llength $items]} {incr i 3} {
lset items $i [expr {[lindex $items $i] - ($width + 20)}]
}
}
if {![llength $items]} {
set messagelength 0
$self stop
}
}
method Enter {id} {
$self itemconfigure $id -fill red
$self stop
}
method Leave {id} {
$self itemconfigure $id -fill #efeb90
$self resume
}
method Scroll {} {
$self stop ;# Make sure we haven't triggered twice by mistake
# Moves all the items along, and keeps track of everything.
set idx 0
set flag 1
set pos [winfo width $self]
set width 0
foreach {id width pos} $items {
incr pos $options(-scrollstep)
if {($pos + $messagelength) < 0} {
set pos [winfo width $self]
set flag 1
} else {
set flag 0
}
$self coords $id $pos 2
lset items [expr {$idx + 2}] $pos
incr idx 3
}
set insertpos [expr {$pos + $width + 20}]
if {$flag && [llength $newitems]} {
# We have just wrapped around the last item, so it is safe to
# append new items now:
foreach {item width} $newitems {
lappend items $item $width $insertpos
incr insertpos $width
incr insertpos 20
incr messagelength $width
incr messagelength 20
}
set newitems [list]
}
lappend event [after $options(-scrollinterval) [list $self Scroll]]
}
method stop {} {
foreach id $event {
after cancel $id
}
set event [list]
}
method resume {} {
lappend event [after $options(-scrollinterval) [list $self Scroll]]
}
delegate method * to hull
delegate option * to hull
destructor {
# Nothing
}
}The basic usage is:
if {0} {
ticker .t
set id [.t add <message> <procname>]
.t add ....
.
.
.t remove $id
.t remove all
}You can specify the amount of pixels each item should move per cycle (-scrollstep), the time interval between each cycle (-scrollinterval, in milliseconds), and the font to use for drawing the messages (-font). The widget is a wrapper round a canvas so you can also use all the canvas configuration options and commands. The ids returned from the ".t add" method are real canvas ids, so you can bind to them etc (note that the widget already defines some bindings on the ids).
A little demo (fetches news articles from USENET and displays them in the ticker):
Code
#!/bin/sh
# Next line restarts with wish \
exec wish "$0" ${1+"$@"}
# Alter these settings for your setup
set Server localhost ;# NNTP server
set Port 119 ;# NNTP port
set Groups [list comp.lang.tcl] ;# list of groups to check
set NumArticles 30 ;# Articles per group to get
set Interval 45 ;# Refresh interval (mins)
#set User "foo"
#set Password "secret"
lappend auto_path [file dirname [info script]]
package require nntp
package require ticker
# Parse the NNTP message headers into an array
proc parse {header} {
array set ret {}
foreach line $header {
if {[regexp {(.*?): (.*)$} $line -> name value]} {
set ret([string trim [string tolower $name]]) $value
}
}
array get ret
}
# Fetch the most recent articles from the group
proc get {news group} {
global NumArticles
$news group $group
array set articles {}
foreach article [$news listgroup] {
array unset fields
array set fields [parse [$news head $article]]
set date $fields(date)
regsub {[\+]\d\d\d\d} $date {} date
if {[catch {clock scan $date} date]} { puts "Skip $date"; continue }
while {[info exists articles($date)]} { incr date }
set articles($date) $article
}
set ids [lrange [lsort -decreasing [array names articles]] 0 \
[expr {$NumArticles - 1}]]
set ret [list]
foreach id $ids {
lappend ret $articles($id)
}
return $ret
}
# Fetch the news
proc getnews {pid} {
global Server Port Groups Interval LastFetch NextFetch
set cur [. cget -cursor]
.t configure -cursor watch
update idletasks
if {[catch {nntp::nntp $Server $Port} news] == 1} {
.t configure -cursor $cur
return -code error "cannot connect to server"
}
if {[info exists ::User]} {
$news authinfo $::User $::Password
}
.t remove all
foreach group $Groups {
.t itemconfigure $pid -text "Fetching group $group..."
update idletasks
set ids [get $news $group]
foreach id $ids {
array set fields [parse [$news head $id]]
set cmd [list show [array get fields] [join [$news body $id] \n]]
regsub -all {%} $cmd {%%} cmd
.t add "$fields(subject) ($fields(from))" $cmd
.t add "***" dummy
}
}
# Make sure it is running correctly:
.t stop
.t resume
# Cleanup nntp connection
$news quit
set LastFetch [clock seconds]
set NextFetch [expr {$LastFetch + ($Interval * 60)}]
after [expr {$Interval * 60000}] [list getnews $::dummy]
.t configure -cursor $cur
}
proc bgerror {args} {
global dummy
puts stderr "ERROR: $args"
puts stderr "$::errorInfo"
if {[info commands ".t"] ne ".t"} {
exit
}
.t stop
.t resume
after 600000 [list getnews $dummy]
}
# Clicking on the *** separator does nothing
proc dummy {args} {}
# Clicking on a message pops up a nice box to view it in
set topid 0
proc show {head msg id} {
array set fields $head
set t [toplevel .msg[incr ::topid]]
wm title $t $fields(subject)
wm geom $t +50+50
frame $t.header -borderwidth 2 -bg black
label $t.header.subject \
-font {Helvetica 9 bold} \
-fg white -bg navy -anchor w \
-width 100 -borderwidth 2 \
-text $fields(subject)
pack $t.header.subject -fill x -expand 1
foreach {name title value} [list \
from From $fields(from) \
group Groups $fields(newsgroups) \
date Date $fields(date) \
] {
set f [frame $t.header.$name]
label $f.l -font {Helvetica 9 bold} \
-fg black -bg #cccccc -anchor w -width 10 \
-text ${title}:
label $f.v -font {Helvetica 9} \
-fg navy -bg #cccccc -anchor w -width 90 \
-text $value
pack $f.l -side left
pack $f.v -side left -fill x -expand 1
pack $f -fill x -expand 1
}
pack $t.header -fill x -side top -anchor n -padx 5 -pady 5
frame $t.b
text $t.b.body -font {Helvetica 10} -yscrollcommand [list $t.b.vsb set]
scrollbar $t.b.vsb -orient vertical -command [list $t.b.body yview]
$t.b.body insert end $msg
$t.b.body configure -state disabled
pack $t.b.vsb -side right -fill y -anchor e
pack $t.b.body -side left -fill both -expand 1
pack $t.b -side bottom -fill both -expand 1
}
proc move {t dir} {
if {$dir eq "left"} {
$t configure -scrollstep -20
} else {
$t configure -scrollstep 20
}
after 500 [list $t configure -scrollstep -2]
}
proc config {} {
global LastFetch NextFetch
set msg "Tk News Ticker V1.0\n"
append msg "By Neil Madden.\n"
append msg "This code is public domain.\n"
append msg "Last fetch: [clock format $LastFetch -format %H:%M:%S]\n"
append msg "Next fetch: [clock format $NextFetch -format %H:%M:%S]"
tk_messageBox -icon info -title "About Tk News Ticker" \
-message $msg
}
proc tryagain {pid} {
global Interval NextFetch
# Get the news
update
set err [catch {getnews $pid} msg]
if {$err} {
.t itemconfigure $pid -text "Error: $msg" -fill red
set NextFetch [expr {[clock seconds] + 600}]
after 600000 [list tryagain $pid]
} else {
.t delete $pid
}
}
wm withdraw .
# Create the ticker
ticker .t -bg navy -relief sunken
# Make the ticker look nice
. configure -relief raised -borderwidth 4
pack [button .left -text "<" -font {Helvetica 12 bold} \
-command {move .t left} -padx 0 -pady 0] \
-side left -expand 0 -padx 0 -pady 0
pack [button .close -text "X" -font {Helvetica 12 bold} \
-command {destroy .} -padx 0 -pady 0] \
-side right -expand 0 -padx 0 -pady 0
pack [button .config -text "?" -font {Helvetica 12 bold} \
-command {config} -padx 0 -pady 0] \
-side right -expand 0 -padx 0 -pady 0
pack [button .right -text ">" -font {Helvetica 12 bold} \
-command {move .t right} -padx 0 -pady 0] \
-side right -expand 0 -padx 0 -pady 0
pack .t -fill x -expand 1
# Show the window
wm overrideredirect . 1
# Place it across the top of the screen
wm geometry . [winfo screenwidth .]x30+0+0
update idletasks
wm deiconify .
set pid [.t create text 2 2 -text "Please wait..." -fill white \
-font {Helvetica 12 bold} -anchor nw]
set LastFetch 0
set NextFetch [clock seconds]
set dummy [.t create text -1000 -1000 -text ""]
tryagain $pidThat's all folks! Could do with a bit more polish, but it's useable.
How about contributing this widget to tklib!
NEM Sure! If anyone has write access to the tklib repository, and thinks this would be useful - then go ahead and include it. I hereby release the code in to the public domain (as I do with all my contributions to this wiki, but just to be explicit about it). I haven't looked at this code in ages, but I seem to remember it was fairly bug free. The interface could probably do with a bit more polish, but I'll leave that to someone else. Oh - it would also need to be updated to the latest version of snit, as I think it doesn't work with the current version (different interfaces). Is there a snit 1.0 yet? If not, it would perhaps be wise to wait for a snit interface freeze before having "standard" mega-widgets which depend on a particular version.
NEM 11Mar04 Updated the package to work with the latest snit (only a couple of changes were needed), and added in basic support for nntp authentication (in the sample application). To use authentication, just set the global ::User and ::Password variables. You might want to add a scheme for hiding the username/password, if you use this feature. Also - I've noticed that the app looks a bit poor on MacOS X (Aqua), as the buttons are too big. I might try and fix that.