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
snit::widget 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]
$self configurelist $args
set height [font metrics $options(-font) -linespace]
$self configure -height [expr {$height + 4}]
$self resume
}
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} {
$self delete $id
if {$id eq "all"} {
set items [list]
} elseif {[set idx [lsearch $items $id]] != -1} {
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 {} {
# Moves all the items along, and keeps track of everything.
$self stop ;# Fixes a bizarre bug where we have too many events
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:
ticker .t
set id [.t add <message> <procname>]
.t add ....
.
.
.t remove $id
.t remove allYou 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):
#!/bin/sh
# Next line restarts with wish \
exec wish "$0" ${1+"$@"}
# Alter these settings for your setup
set Server news.ntlworld.com ;# NNTP server
set Port 119 ;# NNTP port
set Groups [list comp.lang.tcl] ;# list of groups to check
set NumArticles 20 ;# Articles per group to get
set Interval 10 ;# Refresh interval (mins)
lappend auto_path .
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 news
proc getnews {} {
global Server Port Groups NumArticles Interval
if {[catch {nntp::nntp $Server $Port} news] == 1} {
return
}
.t remove all
foreach group $Groups {
$news group $group
for {set i 0} {$i < $NumArticles} {incr i} {
array set fields [parse [$news head]]
.t add "$fields(subject) ($fields(from))" \
[list show [array get fields] [join [$news body] \n]]
.t add "***" dummy
$news next
}
}
# Make sure it is running correctly:
.t stop
.t resume
# Cleanup nntp connection
$news quit
after [expr {$Interval * 60000}] getnews
}
# 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)
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} [subst {group Groups: [list $fields(newsgroups)]
}] {
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 {Courier 9} -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
}
wm withdraw .
# Create the ticker
ticker .t -bg navy -relief sunken
# Make the ticker look nice
. configure -relief raised -borderwidth 4
pack [button .close -text "X" -font {Helvetica 12 bold} \
-command {destroy .} -padx 0 -pady 0] \
-side right -expand 0 -padx 0 -pady 0
pack .t -fill x -expand 1
# Get the news
getnews
# 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 .
That's all folks! Could do with a bit more polish, but it's useable.