Tk Library Source Code

Artifact fcc78f5df6d06831de5d43b8cb4fcca3763bc830:

Attachment "pop3hangstk.tcl" to ticket [815405ffff] added by royterry 2003-10-01 03:20:44.

---

# Demo fetch top hangs under wish or tkcon
# 29Sep03 Roy Terry

array set sp {
    host ?
    login ?
    pass ?
    ch  {}
}

if { ! [info exists sp(log)]} {
    set sp(log) [open sp.log a]
    fconfigure $sp(log) -buffering line
}

package require pop3

proc log::log args {} ;# does this fix hangs? - NOPE

set bgerr ""
proc bgerror args {global bgerr; lappend bgerr $args} ;# ALSO NOT A FIX!

proc spConnect {} {
    global sp
    # Connect and get count/size info
    if {[catch {
        set sp(ch) [pop3::open $sp(host) $sp(login) $sp(pass)]
    } msg]} {
            set sp(errConn) $msg
            return 0
    }

    foreach {cnt by8} [pop3::status $sp(ch)] break
    set sp(bytes) [expr {$by8 * 8}]
    set sp(cnt) $cnt
    set sp(timecon) [clock seconds]
    set sp(timeconMM) [clock clicks -milliseconds]
    return 1
}
proc spTopFetch {nlines {errVAR ""} } {
    # Do top command for nlines on every message
    # return list of results

    set dog [clock seconds]

    global sp
    if {$sp(ch) == ""} {
        return [list]
    }
    if {$errVAR != ""} {upvar $errVAR errout}

    set toplist [list]
    for {set mi 1} {$mi <= $sp(cnt)} {incr mi} {
        puts $sp(log) "spTopFetch: $mi"
        if {[catch {
            set t [pop3::top $sp(ch) $mi $nlines]
        } msg ]} {
            set errout $msg
            return $toplist
        }
        lappend toplist $t
        if {$dog + 50 < [clock seconds]} {
            set errout "too long: 50 seconds! mi=$mi"
            return $toplist
        }
    }
    return $toplist

}
proc spClose {} {
    global sp
    if {$sp(ch) == ""} return
    pop3::close $sp(ch)
    set sp(ch) ""
}

if {[spConnect]} {
    set l [spTopFetch 10 err]
    puts "fetched [llength $l] message tops"
    foreach t $l {
        puts [regexp -inline -nocase subject:.*?\n $t]
    }
}

puts "BGERRORS [join $bgerr \n]"