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

 if {0} {
 ticker .t
 set id [.t add <message> <procname>]
 .t add ....
     .
     .
 .t remove $id
 .t remove all
 }

 #!/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

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References