Updated 2011-07-12 02:41:35 by RLE ▲
 # confcam.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
 #
 # 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.tcl.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 <Control-F2> {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 {<meta http-equiv=\"REFRESH\" content=\"(\d+)\">} [http::data $tok] -> refresh]} {
             ;
         }
         
         if {[regexp {<img src=\"(.*?)\"} [http::data $tok] -> 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