Updated 2015-03-02 02:31:01 by RLE

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 $pid

That'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.