elmer-common 6.1.0.svn.5396.dfsg2-4ubuntu4 / usr / share / elmerpost / help / help.tcl

#
# here is a sample html viewer to demonstrate the library usage
# Copyright (c) 1995 by Sun Microsystems
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# This REQUIRES Tk4.0 -- make sure "wish" on the next line is a 4.0 version
# The next line is a TK comment, but a shell command
#

#if {$tk_version < 4.0 || [regexp {b[123]} $tk_patchLevel] } {
#	puts stderr "This library requires TK4.0, this is only $tk_version, \
#			patchlevel $tk_patchLevel"
#	exit 1
#}
#
#if {[catch {array get env *}]} {
#	puts stderr "This library requires tcl7.4, this version is too old!"
#	exit 1
#}
#puts stderr "Starting sample HTML viewer..."

source $ELMER_POST_HOME/help/http.tcl
source $ELMER_POST_HOME/help/html_library-0.3/html_library.tcl

array set helpTypeAction {
   {}       helpRender
  .html     helpRender
}
# .mpg     "exec mpeg_play"
# .gif     "exec xv"
# .jpg     "exec xv"
  


# Sample hypertext link callback routine - should be replaced by app
# This proc is called once for each <A> tag.
# Applications can overwrite this procedure, as required, or
# replace the HMevents array
#   win:   The name of the text widget to render into
#   href:  The HREF link for this <a> tag.

array set HMevents {
	Enter	{-borderwidth 2 -relief raised}
	Leave	{-borderwidth 2 -relief flat}
	1		{-borderwidth 2 -relief sunken}
	ButtonRelease-1	{-borderwidth 2 -relief raised}
}

# We need to escape any %'s in the href tag name so the bind command
# doesn't try to substitute them.

proc HMlink_setup {win href} {
	global HMevents helpMessage
	regsub -all {%} $href {%%} href2
	foreach i [array names HMevents] {
             if { $i == "Enter" } {
		eval {$win tag bind  L:$href <$i> "set helpMessage $href; $win tag configure \{L:$href2\} $HMevents($i)"}
             } else {
                if { $i == "Leave" } { 
  	          eval {$win tag bind  L:$href <$i> "set helpMessage \{\}; $win tag configure \{L:$href2\} $HMevents($i)"}
                } else {
           	  eval {$win tag bind  L:$href <$i> "$win tag configure \{L:$href2\} $HMevents($i)"}
                }
             }
	}
}


# construct a simple user interface

proc helpSetup {} {

	frame .helpWindow.frame

	menubutton .helpWindow.file -relief raised -bd 2 -text File...    -menu .helpWindow.file.menu
	menubutton .helpWindow.options -relief raised -bd 2 -text Options... -menu .helpWindow.options.menu

#	button .helpWindow.quit  -command { destroy .helpWindow }  -text "Quit"
#        bind .helpWindow <Control-q> "destroy .helpWindow"

	label .helpWindow.status -textvariable helpRunning -width 6 -relief ridge \
			-bd 2 -padx 9 -pady 3

	label .helpWindow.msg -textvariable helpMessage -relief sunken

	frame .helpWindow.dspl
	scrollbar .helpWindow.dspl.scrollbar  -command ".helpWindow.dspl.text yview"  -orient v
	option add *Text.height 40 startup
	option add *Text.width 80 startup
	text .helpWindow.dspl.text  -yscrollcommand ".helpWindow.dspl.scrollbar set" -padx 3 -pady 3 -takefocus 0

	button .helpWindow.back -text "Back" -command \
	      { 
		set helpCurrent [expr $helpCurrent-1]; if { $helpCurrent < 0 } { incr helpCurrent };
		helpRender $helpHistory($helpCurrent);
		set helpCurrent [expr $helpCurrent-1]; if { $helpCurrent < 0 } { incr helpCurrent };
	      }

	pack .helpWindow.frame -side top -expand 1 -fill x
	pack .helpWindow.file .helpWindow.options -in .helpWindow.frame -side left
	pack .helpWindow.status .helpWindow.back -in .helpWindow.frame -side right

	frame .helpWindow.url

	label .helpWindow.url.label  -text "Url: "
	entry .helpWindow.url.entry -textvariable helpUrl

	pack .helpWindow.url.label -side left
	pack .helpWindow.url.entry -side left -expand 1 -fill x
	pack .helpWindow.url -expand 1 -side left -side top -fill x

	pack .helpWindow.msg -side top -expand 1 -fill x

	pack .helpWindow.dspl.scrollbar -side left -expand 0 -fill y
	pack .helpWindow.dspl.text -side left -fill both -expand 1
	pack .helpWindow.dspl -side top -fill both -expand 1

	# set up some sample keyboard bindings for the text widget
	bind .helpWindow.url.entry <Return> { helpRender $helpUrl }
	bind all <End> {.helpWindow.dspl.text yview end}
	bind all <Home> {.helpWindow.dspl.text yview 0.0}
	bind all <Next> {.helpWindow.dspl.text yview scroll 1 page}
	bind all <Prior> {.helpWindow.dspl.text yview scroll -1 page}

	# I'm constantly being criticized for never using menus.
	# so here's a menu.  So there.
	menu .helpWindow.file.menu
	.helpWindow.file.menu add command -label "Quit...Ctrl+Q" -command { destroy .helpWindow }
        bind .helpWindow <Control-q> { destroy .helpWindow }

	menu .helpWindow.options.menu
	.helpWindow.options.menu add command -label "Options menu"
	.helpWindow.options.menu add separator
	.helpWindow.options.menu add command -label "Font size" -foreground red 

	.helpWindow.options.menu add radiobutton -label small -value 0   -variable helpFontSize \
		-command {HMset_state .helpWindow.dspl.text -size $helpFontSize; helpRender $helpUrl}

	.helpWindow.options.menu add radiobutton -label medium -value 4  -variable helpFontSize \
		-command {HMset_state .helpWindow.dspl.text -size $helpFontSize; helpRender $helpUrl}

	.helpWindow.options.menu add radiobutton -label large -value 12  -variable helpFontSize \
		-command {HMset_state .helpWindow.dspl.text -size $helpFontSize; helpRender $helpUrl}

	.helpWindow.options.menu add separator
	.helpWindow.options.menu add command -label "Indent level" -foreground red

	.helpWindow.options.menu add radiobutton -label small -value 0.6 -variable helpIndent \
		-command {HMset_indent .helpWindow.dspl.text $helpIndent}

	.helpWindow.options.menu add radiobutton -label medium -value 1.2 -variable helpIndent \
		-command {HMset_indent .helpWindow.dspl.text $helpIndent}

	.helpWindow.options.menu add radiobutton -label large -value 2.4 -variable helpIndent \
		-command {HMset_indent .helpWindow.dspl.text $helpIndent}

}

# Go helpRender a page.  We have to make sure we don't render one page while
# still helpRendering the previous one.  If we get here from a recursive 
# invocation of the event loop, cancel whatever we were helpRendering when
# we were called.
# If we have a fragment name, try to go there.

proc helpRender { file } {
	global HM.text helpUrl
	global helpRunning helpMessage helpHistory helpCurrent

	incr helpCurrent
	set helpHistory($helpCurrent) $file

	set fragment ""
	regexp {([^#]*)#(.+)} $file dummy file fragment
	if {$file == "" && $fragment != ""} {
		HMgoto .helpWindow.dspl.text $fragment
		return
	}
	HMreset_win .helpWindow.dspl.text
	set helpRunning Busy
	set helpMessage "Displaying $file"
	update idletasks
	set helpUrl $file
	if { $fragment != "" } {
		HMgoto .helpWindow.dspl.text $fragment
	}
	HMparse_html [helpGetHtml $file] {HMrender .helpWindow.dspl.text}
	set helpRunning Ready
	HMset_state .helpWindow.dspl.text -stop 1       ;# stop helpRendering previous page if busy
	set helpMessage ""
}

#
# if html is at the end of http-request this will be called by http_get.
#
proc httpCallback { token } {
    upvar #0 $token state
    global helpText

    set helpText $state(body)
}

# given a file name, return its html, or invent some html if the file can't
# be opened.

proc helpGetHtml { file } {
      global helpHome helpText

      if { [string match http:* $file] } {
	 set token [http_get $file -command httpCallback] 
	 http_wait $token
	 return $helpText
      } else {
	if {[catch {set fd [open $file]} msg]} {
		return "<title>Bad file $file</title>
			<h1>Error reading $file</h1><p>
			$msg<hr>
			<a href=$helpHome>Back</a>"
	}
	set result [read $fd]
	close $fd
	return $result
     }
}

proc helpGetImage { file } {
     set img_file hlp_tmp_img

     set img [open $img_file w]
     fconfigure $img -translation binary
     set token [http_get $file -command httpCallback -channel $img]
     http_wait $token
     close $img

     return $img_file
}


# Override the library link-callback routine for the sample app.
# It only handles the simple cases.

proc HMlink_callback {win href} {
	global helpUrl helpHome helpTypeAction

	if { [string match #* $href] } {
		helpRender $href
		return
	}

        if { [string last ? $href] > 0 } {
          set href [string range $href 0 [expr [string last ? $href]-1]]
        }

	if { [string match /* $href] } {
	   if { [string match http://* $helpUrl] } {
		set tmp [string range $helpUrl 7 end]
		set helpUrl http:/
		set helpUrl $helpUrl/[string range $tmp 0 [string first / $tmp]]
		set helpUrl $helpUrl/$href
	   } else {
		set helpUrl [file dirname $helpHome]/$href
	   }
	} else {
	   if { [string match *:* $href] } {
	       set helpUrl $href
	   } else {
	       set helpUrl [string range $helpUrl 0 [string last / $helpUrl]]$href
	   }
	}

        set extension [file extension $helpUrl]

        if { ![string match *#* $helpUrl] } {
           if { ![string match "*$extension*" [join [array names helpTypeAction] " "]] } {

              set name [tk_getSaveFile -parent .helpWindow -defaultextension [file extension $helpUrl]]

              if { $name != "" } {
                 set file [open $name w]
                 fconfigure $file -translation binary
                 set token [http_get $helpUrl -command httpCallback -channel $file]
                 http_wait $token
                 close $file
              }
              return
           }
        }

        update

	if { $extension == "" } {
	   if { [string last / $helpUrl] != [expr [string length $helpUrl]-1] } { set helpUrl $helpUrl/ }
   	   helpRender $helpUrl
	} else {
#           eval "$helpTypeAction($extension) $helpUrl"
           helpRender $helpUrl
        }

}

# Supply an image callback function
# Read in an image if we don't already have one
# callback to library for display

proc HMset_image {win handle src} {
	global helpUrl helpMessage helpHome

	if {[string match /* $src]} {
	      if { [string match http://* $helpUrl] } {
		set tmp [string range $helpUrl 7 end]
		set image http:/
		set image $image/[string range $tmp 0 [string first / $tmp]]
		set image $image/$src
	      } else {
		set image [file dirname $helpHome]/$src
	      }
	} else {
	   if {[string match *:* $src] } {
		   set image $src
	   } else {
		  set image [string range $helpUrl 0 [string last "/" $helpUrl]]$src
	   }
	}

	set helpMessage "Fetching image: $image"
	update

	if { [string first " $image " " [image names] "] >= 0 } {
	   HMgot_image $handle $image
	} else {
		set type photo

		if { [string match http:* $image] } {
		    set file [helpGetImage $image]
		} else {
		    set file $image
		}

	       if { [file extension $image] == ".bmp" } {set type bitmap}

	       image create $type $image -file $file
	       HMgot_image $handle $image
	}
}

# Handle base tags.  This breaks if more than 1 base tag is in the document

proc HMtag_base {win param text} {
	global helpUrl
	upvar #0 HM$win var
	HMextract_param $param href helpUrl
}

# downloading fonts can take a long time.  We'll override the default
# font-setting routine to permit better user feedback on fonts.  We'll
# keep our own list of installed fonts on the side, to guess when delays
# are likely

proc HMset_font {win tag font} {
	global helpMessage Fonts
	if {![info exists Fonts($font)]} {
		set Fonts($font) 1
		.helpWindow.msg configure -fg blue
		set helpMessage "downloading font $font"
		update
	}
	.helpWindow.msg configure -fg black
	set helpMessage ""
	catch {$win tag configure $tag -font $font} helpMessage
}

# Lets invent a new HTML tag, just for fun.
# Change the color of the text. Use html tags of the form:
# <color value=blue> ... </color>
# We can invent a new tag for the display stack.  If it starts with "T"
# it will automatically get mapped directly to a text widget tag.

proc HMtag_color {win param text} {
	upvar #0 HM$win var
	set value bad_color
	HMextract_param $param value
	$win tag configure $value -foreground $value
	HMstack $win "" "Tcolor $value"
}

proc HMtag_/color {win param text} {
	upvar #0 HM$win var
	HMstack $win / "Tcolor {}"
}

# Add a font size manipulation primitive, so we can use this sample program
# for on-line presentations.  sizes prefixed with + or - are relative.
#  <font size=[+-]3>  ..... </font>.  Note that this is not the same as
# Netscape's <font> tag.

proc HMtag_font {win param text} {
	upvar #0 HM$win var
	set size 0; set sign ""
	HMextract_param $param size
	regexp {([+-])? *([0-9]+)} $size dummy sign size
	if {$sign != ""} {
		set size [expr [lindex $var(size) end] $sign $size]
	}
	HMstack $win {} "size $size"
}

# This version is closer to what Netscape does

proc HMtag_font {win param text} {
	upvar #0 HM$win var
	set size 0; set sign ""
	HMextract_param $param size
	regexp {([+-])? *([0-9]+)} $size dummy sign size
	if {$sign != ""} {
		set size [expr [lindex $var(size) end] $sign  $size*2]
		HMstack $win {} "size $size"
	} else {
		HMstack $win {} "size [expr 10 + 2 * $size]"
	}
}

proc HMtag_/font {win param text} {
	upvar #0 HM$win var
	HMstack $win / "size {}"
}


proc help { { address "index.html" } } {
 
     global ELMER_POST_HOME helpHome helpHistory helpCurrent

     if { [winfo exists .helpWindow] } {
	wm iconify .helpWindow
	wm deiconify .helpWindow
     } else {
	toplevel .helpWindow
	wm title .helpWindow "ELMER POST HELP"
    }


  # set initial values
  set helpFontSize 0                            ;# font size adjustment
  set helpIndent 1.2                            ;# tab spacing (cm)
  if { [string match http:* $address] } {
     set helpHome $address
  } else {
     set helpHome $ELMER_POST_HOME/help/$address        ;# home document
  }
  set helpUrl $helpHome                         ;# current file
  set helpRunning Busy                          ;# page status
  set helpMessage ""                            ;# message line

  # make the interface and render the home page

  set helpCurrent -1

   catch helpSetup                              ;# the catch lets us re-source this file

  HMinit_win   .helpWindow.dspl.text
  HMset_state  .helpWindow.dspl.text -size $helpFontSize
  HMset_indent .helpWindow.dspl.text $helpIndent

  helpRender $helpHome
}