| 1 | #!/bin/sh |
|---|
| 2 | # -*- mode: Tcl -*- |
|---|
| 3 | # ---------------------------------------------------------------------- |
|---|
| 4 | # ABOUT PANEL |
|---|
| 5 | # |
|---|
| 6 | # This little script lets developers create an "about" page for |
|---|
| 7 | # the first page of a nanoWhim application. It's sort of like a |
|---|
| 8 | # web browser, but it shows only one page and handles the links |
|---|
| 9 | # so they pop things up on the user's desktop |
|---|
| 10 | # |
|---|
| 11 | # RUN AS FOLLOWS: |
|---|
| 12 | # about <file.html> |
|---|
| 13 | # |
|---|
| 14 | # ====================================================================== |
|---|
| 15 | # AUTHOR: Michael McLennan, Purdue University |
|---|
| 16 | # Copyright (c) 2004-2012 HUBzero Foundation, LLC |
|---|
| 17 | # |
|---|
| 18 | # See the file "license.terms" for information on usage and |
|---|
| 19 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
|---|
| 20 | # ====================================================================== |
|---|
| 21 | #\ |
|---|
| 22 | dir=`dirname $0` ; \ |
|---|
| 23 | . $dir/rappture.env ; \ |
|---|
| 24 | exec wish "$0" "$@" |
|---|
| 25 | # ---------------------------------------------------------------------- |
|---|
| 26 | # wish executes everything from here on... |
|---|
| 27 | |
|---|
| 28 | package require http |
|---|
| 29 | package require Rappture |
|---|
| 30 | package require RapptureGUI |
|---|
| 31 | |
|---|
| 32 | option add *BugReport*banner*foreground white |
|---|
| 33 | option add *BugReport*banner*background #a9a9a9 |
|---|
| 34 | option add *BugReport*banner*highlightBackground #a9a9a9 |
|---|
| 35 | option add *BugReport*banner*font -*-helvetica-bold-r-normal-*-18-* |
|---|
| 36 | |
|---|
| 37 | # install a better bug handler |
|---|
| 38 | Rappture::bugreport::install |
|---|
| 39 | |
|---|
| 40 | proc escapeChars {info} { |
|---|
| 41 | regsub -all & $info \001 info |
|---|
| 42 | regsub -all \" $info {\"} info |
|---|
| 43 | regsub -all < $info {\<} info |
|---|
| 44 | regsub -all > $info {\>} info |
|---|
| 45 | regsub -all \001 $info {\&} info |
|---|
| 46 | return $info |
|---|
| 47 | } |
|---|
| 48 | |
|---|
| 49 | # |
|---|
| 50 | # Process command line args to get the name of the HTML file... |
|---|
| 51 | # |
|---|
| 52 | if {[llength $argv] != 1} { |
|---|
| 53 | puts stderr "usage: about.tcl <file.html>" |
|---|
| 54 | exit 1 |
|---|
| 55 | } |
|---|
| 56 | set url [lindex $argv 0] |
|---|
| 57 | |
|---|
| 58 | Rappture::Scroller .scroller -xscrollmode auto -yscrollmode auto |
|---|
| 59 | pack .scroller -expand yes -fill both |
|---|
| 60 | |
|---|
| 61 | Rappture::HTMLviewer .scroller.html -width 640 -height 480 |
|---|
| 62 | .scroller contents .scroller.html |
|---|
| 63 | |
|---|
| 64 | switch -regexp -- $url { |
|---|
| 65 | ^https?:// { |
|---|
| 66 | if {[catch {http::geturl $url} token] == 0} { |
|---|
| 67 | set html [http::data $token] |
|---|
| 68 | http::cleanup $token |
|---|
| 69 | } else { |
|---|
| 70 | set html "<html><body><h1>Oops! Internal Error</h1><p>[escapeChars $token]</p></body></html>" |
|---|
| 71 | } |
|---|
| 72 | .scroller.html load $html |
|---|
| 73 | } |
|---|
| 74 | default { |
|---|
| 75 | if {[string range $url 0 6] == "file://"} { |
|---|
| 76 | set file [string range $url 7 end] |
|---|
| 77 | } else { |
|---|
| 78 | set file $url |
|---|
| 79 | } |
|---|
| 80 | set cmds { |
|---|
| 81 | set fid [open $file r] |
|---|
| 82 | set html [read $fid] |
|---|
| 83 | close $fid |
|---|
| 84 | } |
|---|
| 85 | if {[catch $cmds result]} { |
|---|
| 86 | set html "<html><body><h1>Oops! File Not Found</h1><p>[escapeChars $result]</p></body></html>" |
|---|
| 87 | } |
|---|
| 88 | |
|---|
| 89 | # not HTML? then escape nasty characters and display it. |
|---|
| 90 | if {![regexp {<html>.*</html>} $html]} { |
|---|
| 91 | set html "<html><body><p>[escapeChars $html]</p></body></html>" |
|---|
| 92 | } |
|---|
| 93 | .scroller.html load $html -in $file |
|---|
| 94 | } |
|---|
| 95 | } |
|---|
