# confcam.tcl - Copyright (C) 2004 Pat Thoyts # # Display the conference pictures in a Tk window. # # $Id: 12683,v 1.2 2006-01-20 07:00:46 jcw Exp $ package require Tk 8; # Tk package require Img; # Img package require http; # Tcl package require autoproxy; # tcllib 1.7 autoproxy::init namespace eval ::confcam { variable masterurl {http://www.kroc.tk/tcl2004/wc.html} variable afterid variable stopped } proc ::confcam::CreateGui {{standalone 1}} { set dlg [toplevel .conferencecam] wm title $dlg {Tcl2004 Conference Cam} label $dlg.image label $dlg.status -width 60 -relief sunken -border 1 -anchor w button $dlg.stop -text Start -command [namespace origin Start] button $dlg.close -text Close -command [namespace origin Close] grid $dlg.image - - -sticky news grid $dlg.status $dlg.stop $dlg.close -sticky news grid rowconfigure $dlg 0 -weight 1 grid columnconfigure $dlg 0 -weight 1 bind $dlg {console show} if {$standalone} { Start tkwait window $dlg } } proc ::confcam::Display {imagename} { .conferencecam.image configure -image $imagename } proc ::confcam::Status {text} { .conferencecam.status configure -text $text } proc ::confcam::Close {} { Stop destroy .conferencecam } proc ::confcam::Stop {} { variable afterid variable stopped catch {after cancel $afterid} set stopped 1 .conferencecam.stop configure -text Start \ -command [namespace origin Start] } proc ::confcam::Start {} { after 1 [namespace origin Fetch] .conferencecam.stop configure -text Stop \ -command [namespace origin Fetch] } proc ::confcam::Fetch {} { variable masterurl variable afterid variable stopped set stopped 0 set refresh 0 Status "Fetching master web page." set tok [FetchUrlToken $masterurl] if {$tok != {}} { upvar \#0 $tok state array set meta $state(meta) if {[info exists meta(REFRESH)]} { set refresh $meta(REFRESH) } elseif {[regexp {} [http::data $tok] -> refresh]} { ; } if {[regexp { imgurl]} { FetchImage $imgurl if {!$stopped && $refresh > 0} { Status "Next image in $refresh seconds." set afterid [after [expr {$refresh * 1000}]\ [list [namespace origin Fetch]]] } } http::cleanup $tok } } proc ::confcam::FetchImage {url} { Status "fetching image from \"$url\"" set name [file join c:/ temp wc.jpg] set f [open $name w] fconfigure $f -translation binary set imtok [http::geturl $url -binary true -channel $f] flush $f close $f image create photo wc -file $name Display wc Status "Ready." http::cleanup $imtok } # ------------------------------------------------------------------------- # Fetch the target page and cope with HTTP problems. # This deals with server errors and proxy authentication failure # and handles HTTP redirection. # proc ::confcam::FetchUrlToken {url} { set html "" set err "" set tok [http::geturl $url -timeout 30000] if {[string equal [http::status $tok] "ok"]} { if {[http::ncode $tok] >= 500} { set err "server error: [http::code $tok]" } elseif {[http::ncode $tok] >= 400} { set err "authentication error: [http::code $tok]" } elseif {[http::ncode $tok] >= 300} { upvar \#0 $tok state array set meta $state(meta) if {[info exists meta(Location)]} { return [FetchUrlToken $meta(Location)] } else { set err [http::code $tok] } } } else { set err [http::error $tok] } if {[string length $err] > 0} { Error $err http::cleanup $tok set tok {} } return $tok } proc ::confcam::Error {msg} { if {[string length [package provide Tk]] > 0} { tk_messageBox -title "webviewer error" -icon error -message $msg } else { puts stderr $msg } } if {!$tcl_interactive} { wm withdraw . ::confcam::CreateGui 1 } ---- [Category Internet]