home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / demos / Tkhtml / ss.tcl < prev   
Encoding:
Text File  |  2001-10-22  |  9.4 KB  |  426 lines
  1. # @(#) $Id: ss.tcl,v 1.11 2001/06/17 22:45:35 peter Exp $
  2. #
  3. # This script implements the "ss" application.  "ss" implements
  4. # a presentation slide-show based on HTML slides.
  5. # 
  6. wm title . {Tk Slide Show}
  7. wm iconname . {SlideShow}
  8.  
  9. package require Tkhtml
  10.  
  11. # Attempt to load the HTML widget if it isn't already part
  12. # of the interpreter
  13. #
  14. if {[info command html]==""} {
  15.   foreach f {
  16.     ./tkhtml.so
  17.     /usr/lib/tkhtml.so
  18.     /usr/local/lib/tkhtml.so
  19.     ./tkhtml.dll
  20.   } {
  21.     if {[file exists $f]} {
  22.       if {[catch {load $f Tkhtml}]==0} break
  23.     }
  24.   }
  25. }
  26.  
  27. # Pick the initial filename from the command line
  28. #
  29. set HtmlTraceMask 0
  30. set file {}
  31. foreach a $argv {
  32.   if {[regexp {^debug=} $a]} {
  33.     scan $a "debug=0x%x" HtmlTraceMask
  34.   } else {
  35.     set file $a
  36.   }
  37. }
  38.  
  39. # These are images to use with the actual image specified in a
  40. # "<img>" markup can't be found.
  41. #
  42. image create photo biggray -data {
  43.     R0lGODdhPAA+APAAALi4uAAAACwAAAAAPAA+AAACQISPqcvtD6OctNqLs968+w+G4kiW5omm
  44.     6sq27gvH8kzX9o3n+s73/g8MCofEovGITCqXzKbzCY1Kp9Sq9YrNFgsAO///
  45. }
  46. image create photo smgray -data {
  47.     R0lGODdhOAAYAPAAALi4uAAAACwAAAAAOAAYAAACI4SPqcvtD6OctNqLs968+w+G4kiW5omm
  48.     6sq27gvH8kzX9m0VADv/
  49. }
  50.  
  51. # Build the half-size view of the page
  52. #
  53. frame .mbar -bd 2 -relief raised
  54. pack .mbar -side top -fill x
  55. menubutton .mbar.help -text File -underline 0 -menu .mbar.help.m
  56. pack .mbar.help -side left -padx 5
  57. set m [menu .mbar.help.m]
  58. $m add command -label Open -underline 0 -command Load
  59. $m add command -label {Full Screen} -underline 0 -command FullScreen
  60. $m add command -label Refresh -underline 0 -command Refresh
  61. $m add separator
  62. $m add command -label Exit -underline 1 -command exit
  63.  
  64. frame .h
  65. pack .h -side top -fill both -expand 1
  66. html .h.h \
  67.   -width 512 -height 384 \
  68.   -yscrollcommand {.h.vsb set} \
  69.   -xscrollcommand {.f2.hsb set} \
  70.   -padx 5 \
  71.   -pady 9 \
  72.   -formcommand FormCmd \
  73.   -imagecommand "ImageCmd 1" \
  74.   -scriptcommand ScriptCmd \
  75.   -appletcommand AppletCmd \
  76.   -hyperlinkcommand HyperCmd \
  77.   -fontcommand pickFont \
  78.   -appletcommand {runApplet small} \
  79.   -bg white -tablerelief raised
  80. .h.h token handler meta "Meta .h.h"
  81.  
  82. if {$HtmlTraceMask} {
  83.   .h.h config -tablerelief flat
  84. }
  85.  
  86. # This routine is called to pick fonts for the half-size window.
  87. #
  88. proc pickFont {size attrs} { 
  89.   # puts "FontCmd: $size $attrs"
  90.   set a [expr {-1<[lsearch $attrs fixed]?{courier}:{charter}}]
  91.   set b [expr {-1<[lsearch $attrs italic]?{italic}:{roman}}]
  92.   set c [expr {-1<[lsearch $attrs bold]?{bold}:{normal}}]
  93.   set d [expr {int(12*pow(1.2,$size-4))}]
  94.   list $a $d $b $c
  95. }
  96.  
  97. # This routine is called to pick fonts for the fullscreen view.
  98. #
  99. set baseFontSize 24
  100. proc pickFontFS {size attrs} { 
  101.   # puts "FontCmd: $size $attrs"
  102.   set a [expr {-1<[lsearch $attrs fixed]?{courier}:{charter}}]
  103.   set b [expr {-1<[lsearch $attrs italic]?{italic}:{roman}}]
  104.   set c [expr {-1<[lsearch $attrs bold]?{bold}:{normal}}]
  105.   global baseFontSize
  106.   set d [expr {int($baseFontSize*pow(1.2,$size-4))}]
  107.   list $a $d $b $c
  108. } 
  109.  
  110. proc HyperCmd {args} {
  111.    puts "HyperlinkCommand: $args"
  112. }
  113.  
  114. # This routine is called to run an applet
  115. #
  116. proc runApplet {size w arglist} {
  117.   global AppletArg
  118.   catch {unset AppletArg}
  119.   foreach {name value} $arglist {
  120.     set AppletArg([string tolower $name]) $value
  121.   }
  122.   if {![info exists AppletArg(src)]} return
  123.   set src [.h.h resolve $AppletArg(src)]
  124.   set AppletArg(window) $w
  125.   set AppletArg(fontsize) $size
  126.   if {[catch {uplevel #0 "source $src"} msg]} {
  127.     puts "Applet error: $msg"
  128.   }
  129. }
  130.  
  131. proc FormCmd {n cmd args} {
  132.  # puts "FormCmd: $n $cmd $args"
  133.  #  switch $cmd {
  134.  #   select -
  135.  #   textarea -
  136.  #   input {
  137.  #     set w [lindex $args 0]
  138.  #     label $w -image smgray
  139.  #   }
  140.  # }
  141. }
  142. proc ImageCmd {hs args} {
  143.   global OldImages Images
  144.   set fn [lindex $args 0]
  145.   if {[info exists OldImages($fn)]} {
  146.     set Images($fn) $OldImages($fn)
  147.     unset OldImages($fn)
  148.     return $Images($fn)
  149.   }
  150.   if {[catch {image create photo -file $fn} img]} {
  151.     if {$hs} {
  152.       return smallgray
  153.     } else {
  154.       return biggray
  155.     }
  156.   }
  157.   if {$hs} {
  158.     set img2 [image create photo]
  159.     $img2 copy $img -subsample 2 2
  160.     image delete $img
  161.     set img $img2
  162.   }
  163.   if {[image width $img]*[image height $img]>20000} {
  164.     global BigImages
  165.     set b [image create photo -width [image width $img] \
  166.            -height [image height $img]]
  167.     set BigImages($b) $img
  168.     set img $b
  169.     after idle "MoveBigImage $b"
  170.   }
  171.   set Images($fn) $img
  172.   return $img
  173. }
  174. proc MoveBigImage b {
  175.   global BigImages
  176.   if {![info exists BigImages($b)]} return
  177.   $b copy $BigImages($b)
  178.   image delete $BigImages($b)
  179.   unset BigImages($b)
  180. }
  181.   
  182. proc ScriptCmd {args} {
  183.   # puts "ScriptCmd: $args"
  184. }
  185. proc AppletCmd {w arglist} {
  186.   # puts "AppletCmd: w=$w arglist=$arglist"
  187.   # label $w -text "The Applet $w" -bd 2 -relief raised
  188. }
  189.  
  190. # This binding fires when there is a click on a hyperlink
  191. #
  192. proc HrefBinding {w x y} {
  193.   set new [$w href $x $y]
  194.   # puts "link to [list $new]";
  195.   if {$new!=""} {
  196.     ProcessUrl $new
  197.   }
  198. }
  199. bind HtmlClip <1> {KeyPress %W Down}
  200. bind HtmlClip <3> {KeyPress %W Up}
  201. bind HtmlClip <2> {KeyPress %w Down}
  202.  
  203. # Clicking button three on the small screen causes the full-screen view
  204. # to appear.
  205. #
  206. # bind .h.h.x <3> FullScreen
  207.  
  208. # Handle all keypress events on the screen
  209. #
  210. bind HtmlClip <KeyPress> {KeyPress %W %K}
  211. proc KeyPress {w keysym} {
  212.   global hotkey key_block
  213.   if {[info exists key_block]} return
  214.   set key_block 1
  215.   after 250 {catch {unset key_block}}
  216.   if {[info exists hotkey($keysym)]} {
  217.     ProcessUrl $hotkey($keysym)
  218.   }
  219.   switch -- $keysym {
  220.     Escape {
  221.       if {[winfo exists .fs]} {FullScreenOff} {FullScreen}
  222.     }
  223.   }
  224. }
  225.  
  226.  
  227. # Finish building the half-size screen
  228. #
  229. pack .h.h -side left -fill both -expand 1
  230. scrollbar .h.vsb -orient vertical -command {.h.h yview}
  231. pack .h.vsb -side left -fill y
  232.  
  233. frame .f2
  234. pack .f2 -side top -fill x
  235. frame .f2.sp -width [winfo reqwidth .h.vsb] -bd 2 -relief raised
  236. pack .f2.sp -side right -fill y
  237. scrollbar .f2.hsb -orient horizontal -command {.h.h xview}
  238. pack .f2.hsb -side top -fill x
  239.  
  240. #proc FontCmd {args} {
  241. #  puts "FontCmd: $args"
  242. #  return {Times 12}
  243. #}
  244. #proc ResolverCmd {args} {
  245. #  puts "Resolver: $args"
  246. #  return [lindex $args 0]
  247. #}
  248.  
  249. set lastDir [pwd]
  250. proc Load {} {
  251.   set filetypes {
  252.     {{Html Files} {.html .htm}}
  253.     {{All Files} *}
  254.   }
  255.   global lastDir htmltext
  256.   set f [tk_getOpenFile -initialdir $lastDir -filetypes $filetypes]
  257.   if {$f!=""} {
  258.     LoadFile $f
  259.     set lastDir [file dirname $f]
  260.   }
  261. }
  262.  
  263. # Clear the screen.
  264. #
  265. proc Clear {} {
  266.   global Images OldImages hotkey
  267.   if {[winfo exists .fs.h]} {set w .fs.h} {set w .h.h}
  268.   $w clear
  269.   catch {unset hotkey}
  270.   ClearBigImages
  271.   ClearOldImages
  272.   foreach fn [array names Images] {
  273.     set OldImages($fn) $Images($fn)
  274.   }
  275.   catch {unset Images}
  276. }
  277. proc ClearOldImages {} {
  278.   global OldImages
  279.   foreach fn [array names OldImages] {
  280.     image delete $OldImages($fn)
  281.   }
  282.   catch {unset OldImages}
  283. }
  284. proc ClearBigImages {} {
  285.   global BigImages
  286.   foreach b [array names BigImages] {
  287.     image delete $BigImages($b)
  288.   }
  289.   catch {unset BigImages}
  290. }
  291.  
  292. # Read a file
  293. #
  294. proc ReadFile {name} {
  295.   if {[catch {open $name r} fp]} {
  296.     tk_messageBox -icon error -message $fp -type ok
  297.     return {}
  298.   } else {
  299.     set r [read $fp [file size $name]]
  300.     close $fp
  301.     return $r
  302.   }
  303. }
  304.  
  305. # Process the given URL
  306. #
  307. proc ProcessUrl {url} {
  308.   switch -glob -- $url {
  309.     file:* {
  310.       LoadFile [string range $url 5 end]
  311.     }
  312.     exec:* {
  313.       regsub -all \\+ [string range $url 5 end] { } url
  314.       eval exec $url &
  315.     }
  316.     default {
  317.       LoadFile $url
  318.     }
  319.   }
  320. }
  321.  
  322. # Load a file into the HTML widget
  323. #
  324. proc LoadFile {name} {
  325.   set html [ReadFile $name]
  326.   if {$html==""} return
  327.   Clear
  328.   global LastFile
  329.   set LastFile $name
  330.   if {[winfo exists .fs.h]} {set w .fs.h} {set w .h.h}
  331.   $w config -base $name -cursor watch
  332.   $w parse $html
  333.   $w config -cursor top_left_arrow
  334.   ClearOldImages
  335. }
  336.  
  337. # Refresh the current file.
  338. #
  339. proc Refresh {} {
  340.   global LastFile
  341.   if {![info exists LastFile]} return
  342.   LoadFile $LastFile
  343. }
  344.  
  345. # This routine is called whenever a "<meta>" markup is seen.
  346. #
  347. proc Meta {w tag alist} {
  348.   foreach {name value} $alist {
  349.     set v($name) $value
  350.   }
  351.   if {[info exists v(key)] && [info exists v(href)]} {
  352.     global hotkey
  353.     set hotkey($v(key)) [$w resolve $v(href)]
  354.   }
  355.   if {[info exists v(next)]} {
  356.     global hotkey
  357.     set hotkey(Down) $v(next)
  358.   }
  359.   if {[info exists v(prev)]} {
  360.     global hotkey
  361.     set hotkey(Up) $v(next)
  362.   }
  363.   if {[info exists v(other)]} {
  364.     global hotkey
  365.     set hotkey(o) $v(other)
  366.   }
  367. }
  368.  
  369. # Go from full-screen mode back to window mode.
  370. #
  371. proc FullScreenOff {} {
  372.   destroy .fs
  373.   wm deiconify .
  374.   update
  375.   raise .
  376.   focus .h.h.x
  377.   Clear
  378.   ClearOldImages
  379.   Refresh 
  380. }
  381.  
  382. # Go from window mode to full-screen mode.
  383. #
  384. proc FullScreen {} {
  385.   if {[winfo exists .fs]} {
  386.     wm deiconify .fs
  387.     update
  388.     raise .fs
  389.     return
  390.   }
  391.   toplevel .fs
  392.   wm overrideredirect .fs 1
  393.   set w [winfo screenwidth .]
  394.   set h [winfo screenheight .]
  395.   wm geometry .fs ${w}x$h+0+0
  396.   # bind .fs <3> FullScreenOff
  397.   html .fs.h \
  398.     -padx 5 \
  399.     -pady 9 \
  400.     -formcommand FormCmd \
  401.     -imagecommand "ImageCmd 0" \
  402.     -scriptcommand ScriptCmd \
  403.     -appletcommand AppletCmd \
  404.     -hyperlinkcommand HyperCmd \
  405.     -bg white -tablerelief raised \
  406.     -appletcommand {runApplet big} \
  407.     -fontcommand pickFontFS \
  408.     -cursor tcross
  409.   pack .fs.h -fill both -expand 1
  410.   .fs.h token handler meta "Meta .fs.h"
  411.   Clear
  412.   ClearOldImages
  413.   Refresh
  414.   update
  415.   focus .fs.h.x
  416. }
  417. focus .h.h.x
  418.  
  419. # Load the file named on the command-line, if there is
  420. # one.
  421. #
  422. update
  423. if {$file!=""} {
  424.   LoadFile $file
  425. }
  426.