Version 2.00 - Special Purpose Browser 
 

The converse of this is tclets
[ScreenShot of Application]

In late January or early February 1999, TV Guide bought out Prevue, and changed the display to be almost identical to that provided by this program. This application is no longer fully functional, because the web pages upon which it depends are no longer being produced. The logic of the program, and the validity of creating specialty applications for web content over which the creator has control remains quite valid.

Version 3.00 is in progress - will use schedules from www.tv1.com

Do you need help with your Tcl/Tk or PerlTk designs? Trying to figure out if this is the best tool for your current project? Looking into cross-platform compatibility? Need a concentrated course for your staff? Write us at <ai@gtcs.com> for consultation, or call 1.307.637.3488
Advanced Integrators, LC

Verson 2.00 was created with vTcl (a recent version), and routines from the previous v1.11 verson of this application were modified to handle multiple windows - then grafted in. It still does not have a central string and message table for ease in multi-lingual configuration, and only small token code segments are intended to ease the use on Windows95/98/NT/2000 or MacIntosh. Yet any of these could easily be added.

Unlike the v1.xx versions of this application, this one uses v2.0 of the standard tcl8.x distribution of html.tcl, complete with its namespace usage. This application, to keep it simpler, still does not use namespaces within this script. 


#!/usr/local/bin/wish8.0
#############################################################################
# Rewritten as a Visual Tcl Project
#
################################
#  Configuration Section
# 



global PrevueLocale; set PrevueLocale {61380}



#  PrevueLocale is the database reference determined by a normal browser
#  lookup at www.prevue.com (or other site using the same schedule info
#  database identifiers as public identifiers)  See menued locations below



global PrevueWhen;   set PrevueWhen   0



#  PrevueWhen is the offset of when we want a schedule for.  Prevue.com,
#  unlike some others, such as www.tvquest.com doesn't seem to keep even
#  a full day's schedule actively on-line at a time, and uses secondary
#  server transfers periodically.  Zero (the default) gets the CURRENT
#  schedule, until moments before an hour.  2 gets current + 2 hours, etc.



global PrevueServer; set PrevueServer www.prevue.com



#  PrevueServer is our default server



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}
	62196 {Tucson TCI}
	60861 {Worcester GrMed}
	63887 {USSB - Mtn}
	}



#  The keys in the above array are extracted from the last five digits
#  of the displayed URL in a selected schedule.  They are a catalog
#  index for the schedule in question.  Those listed are given in
#  the options menu, from a selection by Zip Code, or from the map.

#####
# Items we want flagged as black...  We'll match strings.


set infomercials [list \
{Aspen Wellness Diet} \
{Beautiful U} \
{Building American Dream} \
{Carleton Sheets} \
{Classic Country Collection} \
{Consumer Product Showcase} \
{Feed the Children} \
{Free Computer Learing} \
{Free Money} \
{George Forman Grill} \
{Golden Days of R & R} \
{Infomercial} \
{Larry North} \
{Making Money} \
{Psychic Hot} \
{Secrets to Cash Flow Now} \
{Shop at Home} \
{Success 'N Life} \
{T-Fal Cookware} \
{Thirty Days to Financial Freedom} \
	]


#####
#  Favorites ...  We'll match strings for extra highlighting...


set favorites [list \
	]



#################################
# GLOBAL VARIABLES
#


global appname;set appname {Prevue}
global apprevs; array set apprevs {
 2.00 {{Mon Jan 18 05:18:26 1999 GMT} Complete rewrite: vTcl based, multi-window, added bottom headings and scrollbars, status moved to bottom}
 1.11 {{Mon Jan 18 04:54:08 1999 GMT} Examine failed ad servers}
 1.10 {{} add educational and favorites matches}
 1.09 {{} identify named infomercials for black backgroun and known ancient B&W shows for graying of title}
 1.08 {{} make Ad redirects a little hardier - process Location: HTTP}
 1.07 {{} Round to even hour - CGI seems to have changed.}
 1.06 {{} Change the slice fetched 5 minutes early.}
 1.05 {{} Add an X behind unfetchable/unrenderable ads}
 1.04 {{Mon Aug 31 15:34:51 1998 GMT} documentation update.}
 1.03 {{} added MANUAL selection of [www|pol1|pol2].prevue.com}
 1.02 {{} added parsing for "reloading pages" - needs redirect, though.}
 1.01 {{} minor syntax error corrections}
 1.00 {{} first version with cache management and MIME TYPE cache.}
 0.98 {{} No details}
 0.95 {{} added advertisment fetches.}
 0.94 {{} No details}
 0.93 {{} No details}
 0.92 {{} No details}
 0.91 {{} No details}
 0.90 {{} added recoloring for Off Air, etc.}
 0.00 {{} No details preserved on early versions}
}
global appvers; set appvers [lindex [lsort -real [array names apprevs]] end]
global appdate; set appdate [lindex [lindex apprevs($appvers) 1] 0]
global appcpyr; set appcpyr "Copyright \xA9 1998,1999 Bruce Gingery"
global appplug; set appplug [info exists embed_args]

global DISTNAME; set DISTNAME [join [list Mozilla/5.0a2 \
	\(compatible interactive Tcl/Tk v[info patchlevel] browser v$appvers\) \
	] { }]
global chanfont;set chanfont {Helvetica -10}
global timefont;set timefont {Helvetica -12}
global dispfont;set dispfont {Helvetica -10 bold}
global btnfont; set btnfont  {Helvetica -12}
global menufont;set menufont {Helvetica -12}
global statfont;set statfont {Helvetica -12 bold}
global x y t rootwin refresh refbtn status
global hours; set hours 2
global lasterror; set lasterror {}
global logoimage cachedir tcl_platform env
global nextwin; set nextwin 0
global status; set status(.) {};# reserve as array
global server;
global slocale;
global soffset;
global curwin;
global queue; set queue {}
global widget; 


#################################
# USER DEFINED PROCEDURES
#






proc {init} {argc argv} {
  global cachedir env tcl_platform
  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
  }
  if {[info exists cachedir] && [file isdirectory $cachedir]} {
    set bm [open [file join $cachedir iconbitmap.xbm] w]
    if [info exists bm] {
      puts $bm {
#define icon_width 63
#define icon_height 66
static unsigned char icon_bits[] = {
0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
0x00,0x00,0x00,0xfc,0xff,0xff,0x03,0x00,0x00,0x00,0xf0,0xff,
0xff,0xff,0x7f,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0x07,
0x00,0xf0,0xff,0xff,0xff,0xff,0xff,0x3f,0x00,0xfe,0xff,0xff,
0xff,0xff,0xff,0x7f,0xc0,0xf7,0xff,0xff,0xff,0xff,0xff,0x7f,
0xf8,0xfe,0xff,0xff,0xff,0xff,0xff,0x7f,0xce,0xff,0xff,0xff,
0xff,0xff,0xff,0x7f,0xfb,0xff,0xff,0x03,0x00,0xf0,0xff,0x7f,
0xfe,0xff,0x07,0x00,0x00,0x00,0xf0,0x7f,0xff,0x7f,0x00,0xf0,
0xff,0x03,0x00,0x7f,0xff,0x07,0x00,0xfe,0xff,0x0f,0x00,0x78,
0x7f,0x00,0x80,0xe1,0xff,0x7f,0x00,0x40,0x0f,0x00,0x20,0xf8,
0xff,0xff,0x00,0x00,0x01,0x00,0x10,0xff,0xff,0xff,0x01,0x00,
0x00,0x00,0x84,0xff,0xff,0xff,0x03,0x00,0x00,0x00,0xe2,0xff,
0xff,0xff,0x07,0x00,0x00,0x00,0xf0,0xff,0xff,0xff,0x0f,0x00,
0x00,0x00,0xfc,0xff,0xff,0xff,0x1f,0x00,0x00,0x40,0xfe,0xff,
0xff,0xff,0x1f,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0x3f,0x00,
0x00,0x90,0xff,0xff,0xff,0xff,0x7f,0x00,0x00,0xc8,0x01,0xc0,
0xff,0xff,0x7f,0x00,0x00,0xc0,0xff,0xff,0xff,0xff,0xff,0x00,
0x00,0x20,0x00,0x00,0xc0,0xff,0xff,0x00,0x00,0x32,0x00,0x00,
0xc0,0xff,0xff,0x00,0x00,0x30,0x00,0x00,0xc0,0xff,0xff,0x00,
0x00,0x39,0x00,0x00,0xc0,0x3f,0xe0,0x00,0x00,0x2f,0x00,0x00,
0xc0,0xdf,0xff,0x01,0x80,0xef,0x3f,0xf0,0xff,0x6f,0xc0,0x01,
0x80,0xff,0x3f,0x10,0xff,0x2f,0xe0,0x01,0xc0,0xff,0x37,0x10,
0xff,0x17,0xe0,0x01,0xc0,0xff,0x17,0x10,0xff,0x1b,0xf0,0x01,
0xc0,0xff,0x17,0x18,0xfe,0x0d,0xf8,0x01,0xc0,0xff,0x17,0x08,
0xfe,0x06,0xfc,0x01,0xc0,0xff,0x1b,0x08,0x7e,0x03,0xfc,0x01,
0xc0,0xff,0x1b,0x08,0x7c,0x01,0xfe,0x00,0xe0,0xff,0x1b,0x08,
0xbc,0x01,0xff,0x00,0xe0,0xff,0x1b,0x08,0xdc,0x00,0xff,0x00,
0xe0,0xff,0x1b,0x08,0x7c,0x80,0xff,0x00,0xe0,0xff,0x0b,0x18,
0x38,0xc0,0xff,0x00,0xe0,0xff,0x0b,0x1c,0x18,0xe0,0x7f,0x00,
0xe0,0xff,0x0b,0x1c,0x18,0xe0,0x7f,0x00,0xe0,0xff,0x0d,0x1c,
0x00,0xf0,0x3f,0x00,0xe0,0xff,0x0d,0x3c,0x00,0xf8,0x3f,0x00,
0xe0,0xff,0x0d,0x3c,0x00,0xfc,0x1f,0x00,0xe0,0xff,0x0d,0x3c,
0x00,0xfc,0x1f,0x00,0xc0,0xff,0x0d,0x3c,0x00,0xfe,0x0f,0x00,
0xc0,0xff,0x05,0x3e,0x00,0xff,0x0f,0x00,0xc0,0xff,0x05,0x7e,
0x00,0xff,0x07,0x00,0x80,0xff,0x05,0x7e,0x80,0xff,0x07,0x40,
0x80,0xff,0x06,0x7e,0xc0,0xff,0x01,0x10,0x00,0xff,0x06,0x7e,
0xe0,0xff,0x01,0x6c,0x00,0xff,0x06,0x7e,0xe0,0xff,0x00,0x73,
0x00,0xfe,0x06,0x7e,0xf0,0x7f,0xe0,0x3e,0x00,0xfe,0x07,0xfe,
0xff,0x3f,0xf8,0x0f,0x00,0xfc,0xff,0xff,0xff,0x1f,0xff,0x03,
0x00,0xf8,0xff,0xff,0xff,0xef,0xff,0x00,0x00,0xf0,0xff,0xff,
0xff,0xff,0x1f,0x00,0x00,0xc0,0xff,0xff,0xff,0xff,0x03,0x00,
0x00,0x80,0xff,0xff,0xff,0x7f,0x00,0x00,0x00,0x00,0xfe,0xff,
0xff,0x03,0x00,0x00,0x00,0x00,0xf0,0xff,0x2f,0x00,0x00,0x00};
}
      close $bm
      unset bm
    }
    set bm [open [file join $cachedir iconbitmask.xbm] w]
    if [info exists bm] {
      puts $bm {
#define mask_width 63
#define mask_height 66
static unsigned char mask_bits[] = {
0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
0x00,0x00,0x00,0xfc,0xff,0xff,0x03,0x00,0x00,0x00,0xf0,0xff,
0xff,0xff,0x7f,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0x07,
0x00,0xf0,0xff,0xff,0xff,0xff,0xff,0x3f,0x00,0xfe,0xff,0xff,
0xff,0xff,0xff,0x7f,0xc0,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,
0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xfe,0xff,0xff,0xff,
0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0x03,0x00,0xf0,0xff,0x7f,
0xff,0xff,0x07,0x00,0x00,0x00,0xf0,0x7f,0xff,0x7f,0x00,0xf0,
0xff,0x03,0x00,0x7f,0xff,0x07,0x00,0xfe,0xff,0x0f,0x00,0x78,
0x7f,0x00,0x80,0xff,0xff,0x7f,0x00,0x40,0x0f,0x00,0xe0,0xff,
0xff,0xff,0x00,0x00,0x01,0x00,0xf8,0xff,0xff,0xff,0x01,0x00,
0x00,0x00,0xfc,0xff,0xff,0xff,0x03,0x00,0x00,0x00,0xff,0xff,
0xff,0xff,0x07,0x00,0x00,0x80,0xff,0xff,0xff,0xff,0x0f,0x00,
0x00,0xc0,0xff,0xff,0xff,0xff,0x1f,0x00,0x00,0xe0,0xff,0xff,
0xff,0xff,0x1f,0x00,0x00,0xf0,0xff,0xff,0xff,0xff,0x3f,0x00,
0x00,0xf0,0xff,0xff,0xff,0xff,0x7f,0x00,0x00,0xfc,0xff,0xff,
0xff,0xff,0x7f,0x00,0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0x00,
0x00,0xfe,0xff,0xff,0xff,0xff,0xff,0x00,0x00,0xfe,0xff,0xff,
0xff,0xff,0xff,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0x00,
0x00,0xff,0xff,0xff,0xff,0xff,0xff,0x00,0x00,0xff,0xff,0xff,
0xff,0xff,0xff,0x01,0x80,0xff,0xff,0xff,0xff,0xff,0xff,0x01,
0x80,0xff,0xff,0xff,0xff,0xff,0xff,0x01,0xc0,0xff,0xff,0xff,
0xff,0xff,0xff,0x01,0xc0,0xff,0xff,0xff,0xff,0xff,0xff,0x01,
0xc0,0xff,0xff,0xff,0xff,0xff,0xff,0x01,0xc0,0xff,0xff,0xff,
0xff,0xff,0xff,0x01,0xc0,0xff,0xff,0xff,0xff,0xff,0xff,0x01,
0xc0,0xff,0xff,0xff,0xff,0xff,0xff,0x00,0xe0,0xff,0xff,0xff,
0xff,0xff,0xff,0x00,0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0x00,
0xe0,0xff,0xff,0xff,0xff,0xff,0xff,0x00,0xe0,0xff,0xff,0xff,
0xff,0xff,0xff,0x00,0xe0,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,
0xe0,0xff,0xff,0xff,0xff,0xff,0x7f,0x00,0xe0,0xff,0xff,0xff,
0xff,0xff,0x3f,0x00,0xe0,0xff,0xff,0xff,0xff,0xff,0x3f,0x00,
0xe0,0xff,0xff,0xff,0xff,0xff,0x1f,0x00,0xe0,0xff,0xff,0xff,
0xff,0xff,0x1f,0x00,0xc0,0xff,0xff,0xff,0xff,0xff,0x0f,0x00,
0xc0,0xff,0xff,0xff,0xff,0xff,0x0f,0x00,0xc0,0xff,0xff,0xff,
0xff,0xff,0x07,0x00,0x80,0xff,0xff,0xff,0xff,0xff,0x07,0x40,
0x80,0xff,0xff,0xff,0xff,0xff,0x01,0x70,0x00,0xff,0xff,0xff,
0xff,0xff,0x01,0x7c,0x00,0xff,0xff,0xff,0xff,0xff,0x00,0x7f,
0x00,0xfe,0xff,0xff,0xff,0x7f,0xe0,0x3f,0x00,0xfe,0xff,0xff,
0xff,0x3f,0xf8,0x0f,0x00,0xfc,0xff,0xff,0xff,0x1f,0xff,0x03,
0x00,0xf8,0xff,0xff,0xff,0xef,0xff,0x00,0x00,0xf0,0xff,0xff,
0xff,0xff,0x1f,0x00,0x00,0xc0,0xff,0xff,0xff,0xff,0x03,0x00,
0x00,0x80,0xff,0xff,0xff,0x7f,0x00,0x00,0x00,0x00,0xfe,0xff,
0xff,0x03,0x00,0x00,0x00,0x00,0xf0,0xff,0x3f,0x00,0x00,0x00};
}
      close $bm
      unset bm
    }
  }
}

# init is run DURING script load, we need a cache, and why not, while
# we're accessing the disk directly, anyways. But, to simplify getting
# it going, we will wait to load the http package until after we have
# our About window showing.

init $argc $argv





# to do an array sort of $locations() by value

proc {valuesort} {left right} {
  global locations
  return [string compare $locations($left) $locations($right)]
}




# invoke next window fetch-and-update

proc {doQueue} {} {
  global queue curwin
  if {[llength $queue] == 0} return
  set base [lindex $queue 0]
  if {[llength $queue] == 1} {
    set queue {}
  } else {
    set queue [lrange $queue 1 end]
  }
  if {[string length $base] == 0} {
    doQueue
  } else {
    after 5 dspSchedule $base
  }
}




# enqueue window fetch-and-update

proc {enqueue} {base where when} {
  global queue curwin slocale soffset
  if {[info exists curwin] && [string compare $curwin $base] == 0} {return}
  set slocale($base) $where
  set soffset($base) $when
  lappend queue $base
  if {![info exists curwin]} {
    after 5 doQueue
    return
  }
  if {[string length $curwin] == 0} {
    after 5 doQueue
  }
}




# post fetch status in statusbar

proc {showProgress} {token total current} {
  global curwin
  upvar #0 status($curwin) statline
  upvar #0 $token httpState
  set statline \
    [format "Fetching ... %d bytes of %d, %s" $current $total $httpState(state)]
  update idletasks
}




# Manage our local browser cache

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 curwin 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($curwin)
  set token [::http::geturl $url -progress showProgress -timeout 10000 \
	-channel $cachefile]
  upvar #0 $token httpState
  set frozen 0
  while { [string match eof $httpState(state)] != 1 } {
    incr frozen
    set status($curwin) "Fetch appears to be stalled..."
    update idletasks
#   puts stderr "$httpState(state) [string match eof $httpState(state)]"
    flush stderr
    after 100
    if {$frozen > 30} {

#       time the sucker out - we cannot get the file we want, and
#       usually it's an ad.

        return {}
    }
  }
  set status($curwin) "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
  ::http::Finish $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($curwin) $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($curwin) $statline
  puts $cacheindex [join [list $cachename $url] {|}]
  close $cacheindex
  update idletasks
  return $cachename
}




#  We can snarf HTML files pretty easliy

proc {getHtml} {url} {
  global DISTNAME status curwin lasterror
  ::http::config -accept text/html -useragent $DISTNAME
  set statsave $status($curwin)
  set token [::http::geturl $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($curwin) "Closing connection..."
  update
  ::http::Finish $token
  set status($curwin) $statsave
  update
  if { [info exists httpState(error)] } {
    set lasterror $httpState(http)
    return "error $httpState(http)"
  }
  set lasterror {}
  return $httpState(body)
}




# Build a URL and get the content of it

proc {getSchedule} {stamp} {
  global DISTNAME status server curwin slocale soffset hours lasterror
  ::http::config -accept text/html -useragent "$DISTNAME"
  set URL [join [list {http://} $server($curwin) {/scripts/pol.dll?} \
        {BuildGuidePage&I=} $slocale($curwin) {&ST=} $stamp \
        {&GB=} [expr $hours * 2]] {}]
# set URL http://localhost/~bruce/prevue.html
  set token [http::geturl $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($curwin) "Closing connection..."
  update
  ::http::Finish $token
  if { [info exists httpState(error)] } {
    set lasterror $httpState(http)
    return "error $httpState(http)"
  }
  set lasterror {}
  return $httpState(body)
}




# draw on canvas

proc {makeBlock} {canv x y w {h 20} fill {ridge sunken}} {
  $canv create rectangle \
    $x $y \
    [expr $x + $w] [expr $y + $h] \
    -fill $fill -outline #333333 -width 1
  if { [string match sunken $ridge] } {
    $canv 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] } {
    $canv 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
  }
}




# draw on canvas

>proc {makeContent} {canv x y fg w content} {
  global dispfont
  $canv create text \
    $x $y -anchor center -fill $fg -justify left -font $dispfont \
    -text $content -width $w
}




# draw on canvas

proc {makeChannel} {canv x y fg w content} {
  global chanfont
  $canv create text \
	$x $y -anchor center -fill $fg -justify center -font $chanfont \
	-text $content -width $w
}




# draw on canvas

proc {makeHeading} {canv x y w h bg fg hd} {
  global timefont
  makeBlock $canv $x $y $w $h $bg raised
  $canv create text \
	[expr $x + ( $w / 2 ) ] [expr $y + ( $h / 2 ) ] \
	-anchor center -fill $fg -font $timefont -justify center \
	-text $hd -width $w
}




# Tie two canvas widgets for simultaneous horizontal movement

proc {tied_xview} {base args} {
  eval "$base.c.t xview $args"
  eval "$base.c.c xview $args"
}




# format a unix timestamp

proc {headtime} {t} {
  return [string trimleft [clock format $t -format {%I:%M}] 0]
}




# post status at end of fetch of schedule

proc {statusDone} {t} {
  global curwin slocale locations
  upvar #0 status($curwin) statline
  set statline [format {%s As of %s} $locations($slocale($curwin)) \
	[clock format $t -format {%R %a, %d %b %Y}]]
}




# fetch - parse - display the schedule

proc {dspSchedule} {base} {
  global x y hours refbtn status PrevueWhen slocale autoupdate dispfont
  global lasterror curwin queue soffset
  upvar #0 cachedir cdir logoimage logoimg infomercials infomercial
  upvar #0 favorites favorite
  set curwin $base
  set canv $base.c.c
  set head $base.c.t

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

  $base.mb.fetch configure -state disabled
  update
  set basetime \
	[expr ( ( [clock seconds] + 300 + $soffset($base) ) / 3600 ) * 3600]
  set page [getSchedule $basetime]
  if { [string match error* $page] } {
    set status($base) {Error - see below}
    makeHeading $canv 40 40 560 360 #000000 #F86666
    $base.mb.fetch configure -state normal
    set curwin {}
    return
  }
  if {[string length $page] == 0} {
    set status($base) {No page returned}
    $base.mb.fetch configure -state normal
    set curwin {}
    return
  }
  regexp -nocase {HTTP-EQUIV=\"Refresh\" CONTENT=\"(\d+)\"} \
	$page discard refresh
  set status($base) {Parsing ...}
  update
  set x 0
  if [info exists cdir] {
    set y 60
  } else {
    set y 0
  }
# strip <HEAD> and everything else through <TABLE> from the page
  $canv delete all
  $head delete all
  makeBlock   $canv 0 0 162 72 #CC0000 flat
  makeHeading $canv 0 $y 79 20 #000099 #F8F800 Channel
  makeHeading $head 0  0 79 20 #000099 #F8F800 Channel
  makeHeading $canv 83 $y 196 20 #000099 #F8F800 [headtime $basetime]
  makeHeading $head 83  0 196 20 #000099 #F8F800 [headtime $basetime]
  makeHeading $canv 283 $y 196 20 #000099 #F8F800 \
	[headtime [expr $basetime + 1800]]
  makeHeading $head 283  0 196 20 #000099 #F8F800 \
	[headtime [expr $basetime + 1800]]
  set pwidth 500
  if {$hours > 1} {
    makeHeading $canv 483 $y 196 20 #000099 #F8F800 \
	[headtime [expr $basetime + 3600]]
    makeHeading $head 483  0 196 20 #000099 #F8F800 \
	[headtime [expr $basetime + 3600]]
    makeHeading $canv 683 $y 196 20 #000099 #F8F800 \
	[headtime [expr $basetime + 5400]]
    makeHeading $head 683  0 195 20 #000099 #F8F800 \
	[headtime [expr $basetime + 5400]]
    set pwidth 900
    if {$hours > 2} {
      makeHeading $canv 883 $y 196 20 #000099 #F8F800 \
	[headtime [expr $basetime + 7200]]
      makeHeading $head 883  0 196 20 #000099 #F8F800 \
	[headtime [expr $basetime + 7200]]
      makeHeading $canv 1083 $y 196 20 #000099 #F8F800 \
	[headtime [expr $basetime + 9000]]
      makeHeading $head 1083  0 196 20 #000099 #F8F800 \
	[headtime [expr $basetime + 9000]]
      set pwidth 1100
      if {$hours > 3} {
	makeHeading $canv 1283 $y 196 20 #000099 #F8F800 \
		[headtime [expr $basetime + 10800]]
        makeHeading $head 1283  0 196 20 #000099 #F8F800 \
		[headtime [expr $basetime + 10800]]
	makeHeading $canv 1483 $y 196 20 #000099 #F8F800 \
		[headtime [expr $basetime + 12600]]
        makeHeading $head 1483  0 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 $canv 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 $canv 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 $canv 39 [expr $y + 11] $fgcolor 78 $text
    set shopchan [expr [regexp HSN $text] || [regexp QVC $text] || \
		[regexp HSN $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 {$shopchan} {
	set bgcolor #000033
      }
      if { [regexp -nocase {.*Paid\ Program.*} $text {}] } {
	set bgcolor #000033
	set fgcolor #CCCCCC
      }
      if [info exists infomercial] {
	foreach pat $infomercial {
	  if {[string first "$pat" "$text"] > -1} {
	    set bgcolor #000033
	    set fgcolor #CCCCCC
	  }
	}
      }
#       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 still look 
#       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
      }
#       But, it's the user's program, not Prevue's, so we make
#       favorites take precedence over ALL other colorations...
      if [info exists favorite] {
	foreach pat $favorite {
	  if {[regexp -- $pat "$text" {}]} {
	    set fgcolor #660099
	    set bgcolor #F8F866
	  }
	}
      }
      makeBlock $canv $x $y $w 18 $bgcolor
      makeContent $canv [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
  }
  $canv configure -scrollregion [list 0 0 [expr $pwidth + 4] [expr $y + 10]]
  $head configure -scrollregion [list 0 0 [expr $pwidth + 4] 0]
  $base.mb.fetch configure -state normal -text {Update Schedule}
  statusDone $basetime
  update
  if { ![info exists logoimg] } {
    catch {set logo [getToCache \
	http://www.prevue.com/gifs/24temp/POL_logo_violet.gif image/gif] }
    if {[info exists logo] && [string length $logo] > 0 } {
      set logoimg [image create photo -file [file join $cdir $logo]]
    }
  }
  if [info exists logoimg] {
    $canv create image 10 1 -anchor nw -image $logoimg
    update idletasks
  }
  set page [getHtml [join \
	[list {http://www.prevue.com/scripts/LongAd.asp?I=} \
		$slocale($base) {&S=-1&N=-1&Q=NONE}] {}]]
  if { [string first error $page] == 0 } {
    set curwin {}
    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 [$canv create image 170 0 -anchor nw -image $adi]
	  $canv 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] { }]
	    $canv create line \
		170 0 660 58 660 0 170 58 170 0 \
		-arrow none -capstyle round -joinstyle round \
		-fill #666699 -width 1
	    $canv create text \
		400 20 -anchor center -fill #99F899 -justify left \
		-font $dispfont -text $msg -width 468
	}
      }
    }
  }
  if {[llength $queue] > 0} doQueue
  set curwin {}
}





# at startup, we display the about window for at least 30 seconds
# 10 ms after dropping it, we auto-fetch the first schedule

proc {main} {argc argv} {


  uplevel #0 package require http 2.0


  after 3000 Window hide .about
  after 3010 dspSchedule .prevue
}




#################################
# VTCL GENERATED GUI PROCEDURES
#

>proc {Window} {args} {
  global vTcl
  set cmd [lindex $args 0]
  set name [lindex $args 1]
  set newname [lindex $args 2]
  set rest [lrange $args 3 end]
  if {$name == "" || $cmd == ""} {return}
  if {$newname == ""} {
    set newname $name
  }
  set exists [winfo exists $newname]
  switch $cmd {
    show {
#         Correction from vTcl 1.11:
      if {$exists == "1" && $newname != "."} {wm deiconify $newname; return}
      if {[info procs vTclWindow(pre)$name] != ""} {
        eval "vTclWindow(pre)$name $newname $rest"
      }
      if {[info procs vTclWindow$name] != ""} {
        eval "vTclWindow$name $newname $rest"
      }
      if {[info procs vTclWindow(post)$name] != ""} {
        eval "vTclWindow(post)$name $newname $rest"
      }
    }
    hide    { if $exists {wm withdraw $newname; return} }
    iconify { if $exists {wm iconify $newname; return} }
    destroy {
      if $exists {
        destroy $newname;
#        Modification from vtcl 1.11: auto-die on last window close
        if {[llength [winfo children .]] == 0} {destroy .}
        return
      }
    }
  }
}



proc {vTclWindow.} {base} {
  if {$base == ""} {
    set base .
  }
  ###################
  # CREATING WIDGETS
  ###################
  wm focusmodel $base passive
  wm geometry $base 1x1+0+0
  wm maxsize $base 1265 994
  wm minsize $base 1 1
  wm overrideredirect $base 0
  wm resizable $base 1 1
  wm withdraw $base
  wm title $base "vt.tcl #2"
  ###################
  # SETTING GEOMETRY
  ###################
}



proc {vTclWindow.prevue} {base args} {
  global nextwin chanfont timefont dispfont btnfont menufont statfont status
  global locations which PrevueServer server PrevueWhen PrevueLocale cachedir
  global soffset slocale
  set basename .prevue
  if {$base == ""} {
    set base $basename
  }
  if {[winfo exists $base]} {
    wm deiconify $base; return
  }
  ###################
  # CREATING WIDGETS
  ###################
  toplevel $base -class Toplevel
  wm focusmodel $base passive
  wm geometry $base 640x480+52+52
  wm maxsize $base 1265 994
  wm minsize $base 1 1
  wm overrideredirect $base 0
  wm resizable $base 1 1
  wm title $base "Prevue.com Schedule"
  wm iconname $base "TV-Schedule"
  wm protocol $base WM_DELETE_WINDOW "Window destroy $base"
  if {[info exists cachedir] && \
		[file exists [file join $cachedir iconbitmap.xbm]]} {
     wm iconbitmap $base   "@[file join $cachedir iconbitmap.xbm]"
  }
  if {[info exists cachedir] && \
		[file exists [file join $cachedir iconbitmask.xbm]]} {
     wm iconmask   $base   "@[file join $cachedir iconbitmask.xbm]"
  }
  frame $base.mb \
	-background #666666 \
	-borderwidth 2 \
	-highlightcolor #999999 \
	-highlightbackground #333333 \
	-relief raised
  button $base.mb.quit \
	-activebackground #F8F800 \
	-borderwidth 2 \
	-background #666666 \
	-command "Window destroy ." \
	-cursor pirate \
	-font "$btnfont" \
	-foreground #CCCC00 \
	-highlightbackground #333333 \
	-highlightcolor #999999 \
	-padx 9 -pady 3 \
	-relief groove \
	-text Quit \
	-underline 0 
  bind $base  "$base.mb.quit invoke"
  menubutton $base.mb.opts \
	-activebackground #F8F800 \
	-background #666666 \
	-borderwidth 2 \
	-font "$btnfont" \
	-foreground #CCCC00 \
	-highlightbackground #333333 \
	-highlightcolor #999999 \
	-menu $base.mb.opts.m \
	-padx 9 -pady 3 \
	-relief groove \
	-text Options \
	-underline 0 
  menu $base.mb.opts.m \
        -activebackground #F8F800 \
	-background #666666 \
	-borderwidth 2 \
	-font "$menufont" \
	-foreground #F8F800 \
        -selectcolor SpringGreen \
	-tearoff 0 
  set server($base) $PrevueServer
  $base.mb.opts.m add radiobutton \
	-indicatoron 1 \
	-label {Server: WWW} \
	-selectcolor #F8F800 \
	-value www.prevue.com \
	-variable server($base)
  $base.mb.opts.m add radiobutton \
	-indicatoron 1 \
	-label {Server: POL1} \
	-selectcolor #F8F800 \
	-value pol1.prevue.com \
	-variable server($base)
  $base.mb.opts.m add radiobutton \
	-indicatoron 1 \
	-label {Server: POL2} \
	-selectcolor #F8F800 \
	-value pol2.prevue.com \
	-variable server($base)
  set which($base)   $PrevueLocale
  set slocale($base) $PrevueLocale
  set soffset($base) $PrevueWhen
  foreach g [lsort -ascii -command valuesort [array names locations]] {
    $base.mb.opts.m add separator
    $base.mb.opts.m add radiobutton \
	-command "global slocale soffset;
		  set slocale($base) $g;
		  set soffset($base) 0" \
	-indicatoron 1 \
	-selectcolor SpringGreen \
	-label $locations($g) \
	-value [expr $g + 0] \
	-variable which($base)
    $base.mb.opts.m add radiobutton \
	-command "global slocale soffset;
		  set slocale($base) $g;
		  set soffset($base) 7200" \
	-indicatoron 1 \
	-selectcolor SpringGreen \
	-label "$locations($g) + 2hr" \
	-value [expr $g + 7200] \
	-variable which($base)
    if {$g == $PrevueLocale} {
      $base.mb.opts.m add radiobutton \
	-command "global slocale soffset;
		  set slocale($base) $g;
		  set soffset($base) 14400" \
	-indicatoron 1 \
	-selectcolor SpringGreen \
	-label "$locations($g) + 4hr" \
	-value [expr $g + 14400] \
	-variable which($base)
    }
  }
  menubutton $base.mb.windows \
	-activebackground #F8F800 \
	-background #666666 \
	-borderwidth 2 \
	-font "$btnfont" \
	-foreground #CCCC00 \
	-highlightbackground #333333 \
	-highlightcolor #999999 \
	-menu $base.mb.windows.m \
	-padx 9 -pady 3 \
	-relief groove \
	-text Windows \
	-underline 0
  menu  $base.mb.windows.m \
	-activebackground #F8F800 \
	-background #666666 \
	-borderwidth 2 \
	-font "$menufont" \
	-foreground #F8F800 \
	-selectcolor SpringGreen \
	-tearoff 0
  $base.mb.windows.m add command \
	-command "Window show .about" \
	-label About... 
  $base.mb.windows.m add command \
	-command "global nextwin
		  set w \$nextwin
		  incr nextwin
		  Window show $basename ${basename}_\$w" \
	-label Add...
  $base.mb.windows.m add command \
	-command "Window destroy $base" \
	-label Close \
	-underline 0
  $base.mb.windows.m add separator
  button $base.mb.fetch \
	-activebackground #F8F800 \
	-background #666666 \
	-borderwidth 2 \
	-command "global slocale soffset;
		  enqueue $base \$slocale($base) \$soffset($base)" \
	-font "$btnfont" \
	-foreground #CCCC00 \
	-highlightbackground #333333 \
	-highlightcolor #999999 \
	-padx 9 -pady 3 \
	-relief groove \
	-text {Fetch Schedule} \
	-underline 0 
  bind $base  "$base.mb.fetch invoke"
  bind $base  "$base.mb.fetch invoke"
  frame $base.c \
	-background #000061 \
	-borderwidth 1 \
	-relief sunken
  scrollbar $base.c.hs \
	-activebackground #F8F800 \
	-background #666666 \
	-borderwidth 1 \
	-command "tied_xview $base" \
	-highlightbackground #333333 \
	-highlightcolor #999999 \
	-orient horizontal \
	-troughcolor #000031 \
	-width 10 
  scrollbar $base.c.vs \
	-activebackground #F8F800 \
	-background #666666 \
	-borderwidth 1 \
	-command "$base.c.c yview" \
	-highlightbackground #333333 \
	-highlightcolor #999999 \
	-orient vertical \
	-troughcolor #000031 \
	-width 10 
  canvas $base.c.c \
	-background #333333 \
	-borderwidth 0 \
	-confine 1 \
	-closeenough 3.0 \
	-cursor box_spiral \
	-highlightthickness 1 \
	-relief flat \
	-scrollregion [list 0 0 900 700] \
	-xscrollincrement 21 \
	-xscrollcommand "$base.c.hs set" \
	-yscrollincrement 21 \
        -yscrollcommand "$base.c.vs set" 
   canvas $base.c.t \
	-background #333333 \
	-borderwidth 0 \
	-confine 1 \
	-closeenough 3.0 \
	-cursor {} \
	-height 22 \
	-highlightthickness 1 \
	-relief flat \
	-scrollregion [list 0 0 900 0] \
	-xscrollincrement 21 \
	-xscrollcommand "$base.c.hs set" \
	-yscrollincrement 0
  bind $base.c.c <1> " 
	$base.c.c configure -cursor fleur
	$base.c.c scan mark %x %y
	$base.c.t scan mark %x 0"
  bind $base.c.c  " 
	$base.c.c scan dragto %x %y
	$base.c.t scan dragto %x 0"
  bind $base.c.c  "%W configure -cursor box_spiral"
  set status($base) {}
  label $base.s \
	-background #000031 \
	-borderwidth 0 \
	-font "$statfont" \
	-foreground #F8F800 \
	-textvariable status($base) \
	-relief flat
  ###################
  # SETTING GEOMETRY
  ###################
  pack $base.mb \
	-anchor center -expand 0 -fill x -side top 
  pack $base.mb.quit \
	-anchor center -expand 0 -fill y -side left 
  pack $base.mb.opts \
	-anchor center -expand 0 -fill y -side left
  pack $base.mb.windows \
	-anchor center -expand 0 -fill y -side left
  pack $base.mb.fetch \
	-anchor center -expand 0 -fill y -side right 
  pack $base.c \
	-anchor center -expand 1 -fill both -side top 
  grid columnconf $base.c 0 -weight 1
  grid rowconf $base.c    0 -weight 1
  grid rowconf $base.c    1 -minsize 24 -weight 0
  grid $base.c.hs \
	-column 0 -row 2 -columnspan 1 -rowspan 1 -sticky ew 
  grid $base.c.t \
	-column 0 -row 1 -columnspan 1 -rowspan 1 -sticky ew
  grid $base.c.vs \
	-column 1 -row 0 -columnspan 1 -rowspan 1 -sticky ns 
  grid $base.c.c \
	-column 0 -row 0 -columnspan 1 -rowspan 1 -sticky nesw 
  pack $base.s \
	-anchor center -expand 0 -fill x -side top
  foreach w [winfo children .] {
    if [winfo exists $w.mb.windows.m] {
      set z [$w.mb.windows.m index Close]
      incr z 2
      if {[$w.mb.windows.m index end] >= $z} {
        $w.mb.windows.m delete $z end
      }
      foreach t [winfo children .] {
        if {[winfo exists $t.mb.windows.m] && \
		( [string compare $w $t] != 0 ) } {
          $w.mb.windows.m add command \
		-command "Window show $basename $t
			  raise $t" -label $t
        }
      }
    }
  }
}



proc {vTclWindow.about} {base args} {
  global nextwin chanfont timefont dispfont btnfont menufont cachedir
  global appname apprevs appvers appdate appcpyr appplug tk_patchLevel
  set basename .about
  if {$base == ""} {
    set base $basename
  }
  if {[winfo exists $base]} {
    wm deiconify $base; return
  }
  ###################
  # CREATING WIDGETS
  ###################
  toplevel $base -class Toplevel
  wm focusmodel $base passive
  wm geometry $base 400x250+53+53
  wm maxsize $base 1265 994
  wm minsize $base 1 1
  wm overrideredirect $base 0
  wm resizable $base 1 1
  wm title $base "About prevue.tcl"
  wm iconname $base "About Prevue"
  wm protocol $base WM_DELETE_WINDOW "Window destroy $base"
t;
  if {[info exists cachedir] && \
		[file exists [file join $cachedir iconbitmap.xbm]]} {
     wm iconbitmap $base   "@[file join $cachedir iconbitmap.xbm]"
  }
  if {[info exists cachedir] && \
		[file exists [file join $cachedir iconbitmask.xbm]]} {
     wm iconmask   $base   "@[file join $cachedir iconbitmask.xbm]"
  }
  frame $base.mb \
	-background #666666 \
	-borderwidth 2 \
	-highlightcolor #999999 \
	-highlightbackground #333333 \
	-relief raised
  button $base.mb.close \
	-activebackground #F8F800 \
	-borderwidth 2 \
	-background #666666 \
	-command "Window destroy $base" \
	-font "$btnfont" \
	-foreground #CCCC00 \
	-highlightbackground #333333 \
	-highlightcolor #999999 \
	-padx 9 -pady 3 \
	-relief groove \
	-text Close \
	-underline 0 
  bind $base  "$base.mb.close invoke"
  bind $base  "$base.mb.close invoke"
  button $base.mb.quit \
	-activebackground #F8F800 \
	-borderwidth 2 \
	-background #666666 \
	-command "Window destroy ." \
	-cursor pirate \
	-font "$btnfont" \
	-foreground #CCCC00 \
	-highlightbackground #333333 \
	-highlightcolor #999999 \
	-padx 9 -pady 3 \
	-relief groove \
	-text Quit \
	-underline 0
  bind $base  "$base.mb.quit invoke"
  frame $base.c \
	-background #666666 \
	-borderwidth 2 \
	-highlightcolor #999999 \
	-highlightbackground #333333 \
	-relief flat
  scrollbar $base.c.hs \
	-activebackground #F8F800 \
	-background #666666 \
	-borderwidth 1 \
	-command "$base.c.t xview" \
	-highlightbackground #333333 \
	-highlightcolor #999999 \
	-orient horizontal \
	-troughcolor #000031 \
	-width 10
  scrollbar $base.c.vs \
	-activebackground #F8F800 \
	-background #666666 \
	-borderwidth 1 \
	-command "$base.c.t yview" \
	-highlightbackground #333333 \
	-highlightcolor #999999 \
	-orient vertical \
	-troughcolor #000031 \
	-width 10
  set t [text $base.c.t \
	-background #000031 \
	-borderwidth 0 \
	-foreground #F8F800 \
	-font {Helvetica -12} \
	-highlightthickness 1 \
	-relief flat \
	-xscrollcommand "$base.c.hs set" \
	-yscrollcommand "$base.c.vs set" \
	-wrap none]
  $t tag configure h1 -font "Helvetica -24 bold"
  $t tag configure h2 -font "Helvetica -16 bold&auot;
  $t tag configure b  -font "Helvetica -12 bold"
  $t tag configure n  -font "Helvetica -12"
  $t tag configure tt -font "Courier -12"
  $t tag configure c  -justify center
  $t tag configure ww -lmargin1 .5c -lmargin2 .5c -rmargin .5c -wrap word
  $t insert end \
	"\n$appname Version $appvers\n" {h1 c} \
	"\n$appcpyr\nAll Rights Reserved\n" {h2 c} \
	"\nTcl v[info patchlevel] / Tk v$tk_patchLevel\n" {b c}
  catch {$t insert end \
	"on $tcl_platform(platform) \($tcl_platform(os)\)" {b c}}
  $t insert end \n\n ww
  foreach r [lsort -decreasing -real [array names apprevs]] {
    $t insert end \
	[format %4.2f $r] tt "\t[lindex $apprevs($r) 0]\n" tt \
	"\t[lrange $apprevs($r) 1 end]\n\n" {n ww}
  }
  $t configure -state disabled
  ###################
  # SETTING GEOMETRY
  ###################
  pack $base.mb \
	-anchor center -expand 0 -fill x -side top 
  pack $base.mb.close \
	-anchor center -expand 0 -fill none -side left 
  pack $base.mb.quit \
	-anchor center -expand 0 -fill none -side left 
  pack $base.c \
	-anchor center -expand 1 -fill both -side top 
  grid columnconf $base.c 0 -weight 1
  grid rowconf $base.c    0 -weight 1
  grid $base.c.hs \
	-column 0 -row 1 -columnspan 1 -rowspan 1 -sticky ew 
  grid $base.c.vs \
	-column 1 -row 0 -columnspan 1 -rowspan 1 -sticky ns 
  grid $base.c.t \
	-column 0 -row 0 -columnspan 1 -rowspan 1 -sticky nesw 
  set x [expr [winfo screenwidth $base] / 2 - ( [winfo reqwidth $base] / 2 )]
  set y [expr [winfo screenheight $base] / 2 - ( [winfo reqheight $base] / 2 )]
  wm geometry $base 400x250+$x+$y
}



Window show .
Window show .about
Window show .prevue



main $argc $argv

You can download the above script without HTML escapes or refer to the older (v1.08) version. Rember to shift-click or otherwise select DOWNLOAD if you have the Tclet plugin installed! This script does its own cache management, as a stand alone Tcl/Tk application. That is not valid for most Tclet security policies.