global VERSION
set VERSION 1.08
global DISTNAME
set DISTNAME [join [list Mozilla/5.0a2 \(compatible interactive Tcl/Tk \
v[info patchlevel] browser v$VERSION\) ] { }]
global chanfont
set chanfont {-Adobe-Helvetica-Bold-R-Normal--11-*-*-*-P-*-iso8859-1}
global timefont
set timefont {-Adobe-Helvetica-Bold-R-Normal--12-*-*-*-P-*-iso8859-1}
global dispfont
set dispfont {-Adobe-Helvetica-Bold-R-Normal--11-*-*-*-P-*-iso8859-1}
global btnfont
set btnfont {-Adobe-Helvetica-Medium-R-Normal--14-*-*-*-P-*-iso8859-1}
global menufont
set menufont {-Adobe-Helvetica-Medium-R-Normal--12-*-*-*-P-*-iso8859-1}
global x y t rootwin refresh refbtn status
global hours; set hours 2
global PrevueLocale; set PrevueLocale {61380}
global PrevueWhen; set PrevueWhen 0
global which; set which [expr $PrevueLocale + $PrevueWhen]
global autoupdate autorefresh
global server
set server www
global lasterror;set lasterror {}
array set locations {
62149 {Casper TCI}
61380 {Cheyenne TCI}
61615 {C-Band Mtn}
60770 {Colorado TCI}
63893 {Direct TV Mtn}
63099 {Hartford SNET}
60836 {Hartford TCI}
60835 {Philly ComCst}
60938 {Philly GrMed}
62277 {Salina Cable}
60827 {San Jose TCI}
61054 {Tucson Jones}
62196 {Tucson TCI}
60861 {Worcester GrMed}
63887 {USSB - Mtn}
}
global logoimage
global cachedir tcl_platform env
if [info exists env(PRCACHE)] {
if {![expr [file exists $env(PRCACHE)] && [file isdirectory $env(PRCACHE)]]} {
catch {file mkdir $env(PRCACHE)}
}
set cachedir $env(PRCACHE)
}
if {[expr ![info exists cachedir] && [info exists env(TEMP)]] } {
if { ![expr [file exists $env(TEMP)] && [file isdirectory $env(TEMP)]]} {
catch {file mkdir $env(TEMP)}
}
set cachedir $env(TEMP)
}
if {[expr ![info exists cachedir] && [info exists env(TMP)]]} {
if {![expr [file exists $env(TMP)] && [file isdirectory $env(TMP)]]} {
catch {file mkdir $env(TMP)}
}
set cachedir $env(TMP)
}
if {![info exists cachedir]} {
if [string match windows $tcl_platform(platform)] {
set cachedir C:\windows\temp
# It'll be somewhere if we're really running windows and no TEMP or TMP
} elseif [string match unix $tcl_platform(platform)] {
set cachedir /tmp/pvcache
if { ![file isdirectory $cachedir] } {
file mkdir $cachedir
}
} else {
if [info exists env(HOME)] {
set cachedir [file join $env(HOME) pvcache]
if {![expr [file exists $cachedir] && [file isdirectory $cachedir]]} {
file mkdir $cachedir
}
# } else {
# set cachedir [pwd]
}
}
}
if {![expr [file exists $cachedir] && [file isdirectory $cachedir]]} {
unset cachedir
}
proc valuesort {left right} {
global locations
return [string compare $locations($left) $locations($right)]
}
proc autoRefresh { } {
global refbtn autoupdate
$refbtn configure -foreground SpringGreen
if {$autoupdate == 1} {
after 30000 dspSchedule
}
}
proc showProgress {token total current} {
global status
upvar #0 $token httpState
set status [format "Fetching ... %d bytes of %d, %s" $current $total $httpState(state)]
update idletasks
}
proc cacheManage {index} {
upvar #0 cachedir cdir
set expire [expr [clock seconds] - 10800]
set ixout [open [file join $cdir index.new] w]
if {![info exists ixout]} {return $index}
seek $index 0 start
while { ![eof $index]} {
if [gets $index line] {
set ix [string first | $line]
incr ix -1
set cachename [string range $line 0 $ix]
if {[catch {file mtime [file join $cdir $cachename]} mtime]} {
puts $ixout $line
} else {
if {$mtime < $expire} {
file delete [file join $cdir $cachename]
} else {
puts $ixout $line
}
}
}
}
close $index
file delete -- [file join $cdir index]
file rename [file join $cdir index.new] [file join $cdir index]
return $ixout
}
proc getToCache {url mimetype} {
upvar #0 cachedir cdir
global DISTNAME status lasterror
if {![info exists cdir]} { return {} }
# Let's see if we already have it
set cacheindex [open [file join $cdir index] a+]
if {![info exists cacheindex]} { return {} }
seek $cacheindex 0 start
while {![eof $cacheindex]} {
if [gets $cacheindex line] {
set ix [string first | $line]
set cachename [string range $line 0 [expr $ix - 1]]
set cacheurl [string range $line [expr $ix + 1] end]
if {[string compare $cacheurl $url] == 0} {
close $cacheindex
return $cachename
}
}
}
set cacheindex [cacheManage $cacheindex]
set cachename [clock seconds]
set cachefile [open [file join $cdir $cachename] w]
if {![info exists cachefile]} {
close $cacheindex
return {}
}
fconfigure $cachefile -translation binary
# Nope, let's fetch it.
http_config -accept $mimetype -useragent "$DISTNAME"
set statline $status
set token [http_get $url -progress showProgress -timeout 10000 \
-channel $cachefile]
upvar #0 $token httpState
while { [string match eof $httpState(state)] != 1 } {
puts stderr "$httpState(state) [string match eof $httpState(state)]"
flush stderr
after 100
}
set status "Closing cache and connection..."
update idletasks
if [info exists httpState(meta)] {
array set meta $httpState(meta)
if [info exists meta(Content-Type)] {
if { [regexp -nocase -- {image/(.*)} $meta(Content-Type) {} imgtype] } {
file rename [file join $cdir $cachename] \
[join [list [file join $cdir $cachename] $imgtype] .]
set cachename [join [list $cachename $imgtype] .]
} else {
file rename [file join $cdir $cachename] \
[join [list [file join $cdir $cachename] html] .]
set cachename [join [list $cachename html] .]
}
} else {
file rename [file join $cdir $cachename] \
[join [list [file join $cdir $cachename] html] .]
set cachename [join [list $cachename html] .]
}
} else {
file rename [file join $cdir $cachename] \
[join [list [file join $cdir $cachename] html] .]
set cachename [join [list $cachename html] .]
}
update idletasks
httpFinish $token
if [info exists meta(Location)] {
set meta(Location) [string trim $meta(Location)]
puts -nonewline $cachefile {<A HREF="}
puts -nonewline $cachefile $meta(Location)
puts $cachefile {">Graphic Location</A>}
close $cachefile
set status $statline
puts $cacheindex [join [list $cachename $url] {!}]
flush $cacheindex
close $cacheindex
update idletasks
if [catch {getToCache $meta(Location) image/*} followed] {
return $cachename
} else {
return $followed
}
}
# puts [join [list Cached as $cachename, $url] { }]
# flush stdout
close $cachefile
set status $statline
puts $cacheindex [join [list $cachename $url] {|}]
close $cacheindex
update idletasks
return $cachename
}
proc getHtml {url} {
global DISTNAME status lasterror
http_config -accept text/html -useragent $DISTNAME
set statsave $status
set token [http_get $url -progress showProgress -timeout 10000]
upvar #0 $token httpState
while { [string match eof $httpState(state)] != 1 } {
puts stderr "$httpState(state) [string match eof $httpState(state)]"
flush stderr
after 100
}
set status "Closing connection..."
update
httpFinish $token
set status $statsave
update
if { [info exists httpState(error)] } {
set lasterror $httpState(http)
return "error $httpState(http)"
}
set lasterror {}
return $httpState(body)
}
proc getSchedule {stamp} {
global DISTNAME status server PrevueLocale hours lasterror
http_config -accept text/html -useragent "$DISTNAME"
set URL [join [list {http://} $server {.prevue.com/scripts/pol.dll?} \
{BuildGuidePage&I=} $PrevueLocale {&ST=} $stamp \
{&GB=} [expr $hours * 2]] {}]
# set URL http://localhost/~bruce/prevue.html
set token [http_get $URL -progress showProgress -timeout 60000]
upvar #0 $token httpState
while { [string match eof $httpState(state)] != 1 } {
puts stderr "$httpState(state) [string match eof $httpState(state)]"
flush stderr
after 100
}
set status "Closing connection..."
update
httpFinish $token
if { [info exists httpState(error)] } {
set lasterror $httpState(http)
return "error $httpState(http)"
}
set lasterror {}
return $httpState(body)
}
proc makeBlock {x y w {h 20} fill {ridge sunken}} {
global t
$t create rectangle \
$x $y \
[expr $x + $w] [expr $y + $h] \
-fill $fill -outline #333333 -width 1
if { [string match sunken $ridge] } {
$t create line \
[expr $x + 1] [expr $y + 1 + $h] \
[expr $x + 1 + $w] [expr $y + 1 + $h] \
[expr $x + 1 + $w] [expr $y + 1] \
-arrow none -capstyle round -joinstyle round \
-fill #CCCCCC -width 1
} elseif { [string match raised $ridge] } {
$t create line \
[expr $x + $w - 1] [expr $y - 1] \
[expr $x - 1] [expr $y - 1] \
[expr $x - 1] [expr $y + $h - 1] \
-arrow none -capstyle round -joinstyle round \
-fill #CCCCCC -width 1
}
}
proc makeContent { x y fg w content} {
global t dispfont
$t create text \
$x $y -anchor center -fill $fg -justify left -font $dispfont \
-text $content -width $w
}
proc makeChannel {x y fg w content} {
global t chanfont
$t create text \
$x $y -anchor center -fill $fg -justify center -font $chanfont \
-text $content -width $w
}
proc makeHeading {x y w h bg fg hd} {
global t timefont
makeBlock $x $y $w $h $bg raised
$t create text \
[expr $x + ( $w / 2 ) ] [expr $y + ( $h / 2 ) ] \
-anchor center -fill $fg -font $timefont -justify center \
-text $hd -width $w
}
proc headtime {t} {
return [string trimleft [clock format $t -format {%I:%M}] 0]
}
proc statusDone {t} {
global status PrevueLocale locations
set status [format {%s As of %s} $locations($PrevueLocale) \
[clock format $t -format {%R %a, %d %b %Y}]]
}
proc dspSchedule { } {
global x y t hours refbtn status PrevueWhen PrevueLocale autoupdate dispfont
global lasterror
upvar #0 cachedir cdir logoimage logoimg
# Logo is 118x60 on #000066, http://www.prevue.com/gifs/logo/Pvchannel.JPG
# But http://www.prevue.com/gifs/24temp/POL_logo_violet.gif looks better.
# even though it is a 140x70 pixel image We can let it overlap titles.
# Click Ad is actually 468x60 and loaded from a dynamic image link on
# http://www.prevue.com/scripts/LongAd.asp?I=_____&S=-1&N=-1&Q=NONE
# where _____ is the table value above.
$refbtn configure -state disabled
update
set basetime [expr ( ( [clock seconds] + 300 + $PrevueWhen ) / 3600 ) * 3600]
set page [getSchedule $basetime]
if { [string match error* $page] } {
set status {Error - see below}
makeHeading 40 40 560 360 #000000 #F86666 $page
return
}
if {[string length $page] == 0} {
set status {No page returned}
return
}
regexp -nocase {HTTP-EQUIV=\"Refresh\" CONTENT=\"(\d+)\"} $page foo refresh
set status {Parsing ...}
update
set x 0
if [info exists cdir] {
set y 60
} else {
set y 0
}
$refbtn configure -foreground #CCCC00
if { [catch {expr $refresh + 0}] } {
set refresh 1800
}
after [expr $refresh * 1000] autoRefresh
# strip <HEAD> and everything else through <TABLE> from the page
$t delete all
makeBlock 0 0 162 72 #CC0000 flat
makeHeading 0 $y 79 20 #000099 #F8F800 Channel
makeHeading 83 $y 196 20 #000099 #F8F800 [headtime $basetime]
makeHeading 283 $y 196 20 #000099 #F8F800 [headtime [expr $basetime + 1800]]
set pwidth 500
if {$hours > 1} {
makeHeading 483 $y 196 20 #000099 #F8F800 \
[headtime [expr $basetime + 3600]]
makeHeading 683 $y 196 20 #000099 #F8F800 \
[headtime [expr $basetime + 5400]]
set pwidth 900
if {$hours > 2} {
makeHeading 883 $y 196 20 #000099 #F8F800 \
[headtime [expr $basetime + 7200]]
makeHeading 1083 $y 196 20 #000099 #F8F800 \
[headtime [expr $basetime + 9000]]
set pwidth 1100
if {$hours > 3} {
makeHeading 1283 $y 196 20 #000099 #F8F800 \
[headtime [expr $basetime + 10800]]
makeHeading 1483 $y 196 20 #000099 #F8F800 \
[headtime [expr $basetime + 12600]]
set pwidth 1300
}
}
}
update
incr y 25
set bf [string first {are currently loading data} $page]
if { $bf > -1 } {
set page [string range $page $bf end]
set bf [string first \n $page]
if { $bf > -1 } {
set page [string range $page 0 $bf]
makeHeading 90 120 300 200 #990000 #F8F800 $page
}
}
# loop through rows
while { [set bf [string first <TR> $page]] > -1 } {
set be [string first </TR> $page]
set block [string range $page $bf $be]
incr be 4
set page [string range $page $be end]
regexp -nocase {.*<TH[^B]+BGCOLOR=\"(#[0-9A-Fa-f]+)} $block {} bgcolor
regexp -nocase {.*<TH WIDTH=\"([0-9]+)\%\"} $block {} w
set w [expr int ( $pwidth / 100 * $w ) ]
makeBlock 0 $y 79 18 $bgcolor raised
set ix [string first <FONT $block]
set block [string range $block $ix end]
regexp -nocase \
{<FONT COLOR=\"(#[0-9A-Fa-f]+)\">([^<]+)</FONT>} $block {} fgcolor text
regsub -nocase \
{COLOR=.*>.*</TH>} $block {} block
makeChannel 39 [expr $y + 11] $fgcolor 78 $text
set bs [string first <TD $block]
set x 83
# loop through cells in row
while {$bs > -1} {
set be [string first </TD> $block]
incr be 4
set cell [string range $block $bs $be]
incr be
set block [string range $block $be end]
regexp -nocase {<TD WIDTH=\"([0-9]+)\%\"} $cell {} w
set w [expr $pwidth / 100 * $w]
set w [expr ( int ( $w / 200 ) - 1 ) * 200 + 196]
regexp -nocase {<TD.*BGCOLOR=\"(#[0-9A-Fa-f]+)\"} $cell {} bgcolor
regsub -nocase {.*<FONT} $cell {<FONT} $cell
regexp -nocase {<FONT COLOR=\"(#[0-9A-Fa-f]+)\">([^<]+)</FONT>} $cell \
{} fgcolor text
# Just to demonstrate that we _can_, we'll alter just a few blocks.
# We'll force ``Paid Program'' to near-black background
if { [regexp -nocase {.*Paid\ Program.*} $text {}] } {
set bgcolor #000033
}
# and Off-Air (or Off Air) to black background with gray foreground
if { [regexp -nocase {.*Off.Air.*} $text {}] } {
set bgcolor #000000
set fgcolor #CCCCCC
}
# and change News broadcasts to a very dark cyan. It'll look a bit like
# sprts, but very much like its original deep blue color.
if { [regexp -nocase {.*News.*} $text {}] } {
set bgcolor #003366
}
# and finally, in thanks to the provider, we'll give them a royal purple
# background with gold lettering.
if { [regexp -nocase {Prevue First!} $text {}] } {
set fgcolor #F8F866
set bgcolor #330066
}
makeBlock $x $y $w 18 $bgcolor
makeContent [expr $x + ( $w / 2 ) ] [expr $y + 9] $fgcolor \
[expr $w - 4] $text
incr x [expr $w + 4]
set bs [string first <TD $block]
}
update idletasks
incr y 21
}
$t configure -scrollregion [list 0 0 [expr $pwidth + 4] [expr $y + 10]]
$refbtn configure -state normal
statusDone $basetime
$autoupdate configure -state normal
update
if { ![info exists logoimg] } {
catch {set logo [getToCache \
http://www.prevue.com/gifs/24temp/POL_logo_violet.gif image/gif]}
if { [string length $logo] > 0 } {
set logoimg [image create photo \
-file [file join $cdir $logo]]
}
}
if [info exists logoimg] {
$t create image 10 1 -anchor nw -image $logoimg
update idletasks
}
set page [getHtml [join \
[list {http://www.prevue.com/scripts/LongAd.asp?I=} \
$PrevueLocale {&S=-1&N=-1&Q=NONE}] {}]]
if { [string first error $page] == 0 } {
return
}
set ix [string first {<img src="} $page]
if { $ix > -1 } {
incr ix 10
set page [string range $page $ix end]
set ix [string first \" $page]
if { $ix > -1 } {
incr ix -1
set page [string range $page 0 $ix]
set ad [getToCache "$page" image/*]
if { [string length $ad] > 0 } {
if { ![catch {image create photo -file [file join $cdir $ad]} adi] } {
set i [$t create image 170 0 -anchor nw -image $adi]
$t lower $i all
} else {
set ad [file join $cdir $ad]
set msg [join [list Unable to display advertisement, \
unsupported image format or error return. It is \
cached as $ad \n $lasterror] { }]
$t create line \
170 0 660 58 660 0 170 58 170 0 \
-arrow none -capstyle round -joinstyle round \
-fill #666699 -width 1
$t create text \
400 20 -anchor center -fill #99F899 -justify left \
-font $dispfont -text $msg -width 468
}
}
}
}
}
![[ScreenShot of Window Content]](prevue.gif)