tcl/help.tcl

   1 ##
   2 ## help.tcl
   3 ## minimal generic help system implemented as a mega-widget
   4 ##
   5 ## Jeffrey Hobbs
   6 ## Initiated: 28 October 1996
   7 ##
   8
   9 ##------------------------------------------------------------------------
  10 ## PROCEDURE
  11 ##      help_dialog
  12 ##
  13 ## DESCRIPTION
  14 ##      Implements a minimal generic help system dialog
  15 ##
  16 ## ARGUMENTS
  17 ##      help_dialog <window pathname> <options>
  18 ##
  19 ## OPTIONS
  20 ##      (Any help widget option may be used in addition to these)
  21 ##
  22 ## RETURNS: the toplevel window pathname
  23 ##
  24 ## BINDINGS (in addition to default widget bindings)
  25 ##
  26 ## -dismisstext str                     DEFAULT: Dismiss
  27 ##      The text for the dismiss button (hides the Help dialog).  If
  28 ##      text=={}, the button is not shown.
  29 ##
  30 ## METHODS
  31 ##      These are the methods that an instance of this megawidget recognizes.
  32 ## Aside from those listed here, it accepts methods that are valid for text
  33 ## widgets.
  34 ##
  35 ## configure ?option? ?value option value ...?
  36 ## cget option
  37 ##      Standard tk widget routines.
  38 ##
  39 ## subwidget widget
  40 ##      Returns the true widget path of the specified widget.  Valid
  41 ##      widgets are label, dismiss.
  42 ##
  43 ## hide
  44 ##      Hides the help dialog
  45 ##
  46 ## show
  47 ##      Deiconifies the help dialog
  48 ##
  49 ## NAMESPACE & STATE
  50 ##      The megawidget creates a global array with the classname, and a
  51 ## global array which is the name of each megawidget created.  The latter
  52 ## array is deleted when the megawidget is destroyed.
  53 ##      The procedure help and those beginning with Help are
  54 ## used.  Also, when a widget is created, commands named .$widgetname
  55 ## and HelpDialog$widgetname are created.
  56 ##
  57 ## EXAMPLE USAGE:
  58 if 0 {
  59     helpdialog .h -label "Tiger Help" -title "Tiger Help" -buttons {
  60         {Index    index}
  61         {Contents http://www.acm.org/}
  62     }
  63     .h link index http://www.altavista.digital.com/
  64     .h show
  65 }
  66 ##------------------------------------------------------------------------
  67
  68 ##------------------------------------------------------------------------
  69 ## PROCEDURE
  70 ##      help
  71 ##
  72 ## DESCRIPTION
  73 ##      Implements a minimal generic help system
  74 ##
  75 ## ARGUMENTS
  76 ##      help <window pathname> <options>
  77 ##
  78 ## OPTIONS
  79 ##      (Any frame option may be used in addition to these)
  80 ##
  81 ## RETURNS: the toplevel window pathname
  82 ##
  83 ## BINDINGS (in addition to default widget bindings)
  84 ##
  85 ## -binding event                       DEFAULT: {}
  86 ##      A binding for using the help in a context-sensitive manner.  If
  87 ##      binding is specified, the help dialog will make a bind that event
  88 ##      to all and call the load method with the widget it is over when it
  89 ##      is triggered.  Thus you need to register the widget name as a tag
  90 ##      for it to be recognized in context sensitive help.
  91 ##
  92 ## -buttons buttonlist                  DEFAULT: {}
  93 ##      A list of tuples that define the buttons to display.  Each tuple
  94 ##      must be of the form {"Button Name" tagOrURL}.  For each tuple in
  95 ##      the list, a button is created in the help dialog with the specified
  96 ##      name and its command is set to load the specified tagOrURL.
  97 ##
  98 ## -executable execlist
  99 ## DEFAULT: {{exec netscape -remote "openURL(%s)"} {exec netscape "%s" &}}
 100 ##      A list of lists which represent what commands to evaluate in order
 101 ##      to view the URL.  In the string, %s is replaced with the URL to be
 102 ##      loaded.  %s may not start the string.
 103 ##
 104 ## -inherit TCL_BOOLEAN                 DEFAULT: 1
 105 ##      In combination with a binding specification, tells whether the help
 106 ##      widget should iteratively look for a link associated with a parent
 107 ##      widget when one is not found for the current widget.
 108 ##
 109 ## -label str                           DEFAULT: {}
 110 ##      The text for a label at the top of the dialog.  If text=={}, the
 111 ##      label is not shown.
 112 ##
 113 ## -subst TCL_BOOLEAN                   DEFAULT: 1
 114 ##      Performs a subst on the tagOrURL, allowing you to do delayed
 115 ##      evaluation on the tagOrURL contents.
 116 ##
 117 ## METHODS
 118 ##      These are the methods that an instance of this megawidget recognizes.
 119 ## Aside from those listed here, it accepts methods that are valid for text
 120 ## widgets.
 121 ##
 122 ## configure ?option? ?value option value ...?
 123 ## cget option
 124 ##      Standard tk widget routines.
 125 ##
 126 ## subwidget widget
 127 ##      Returns the true widget path of the specified widget.  Valid
 128 ##      widgets are label.
 129 ##
 130 ## gettag tagOrWidget
 131 ##      Returns an absolute tag reference for a particular tag (following
 132 ##      all links and doing all substs) or {} if no tag exists.
 133 ##
 134 ## link tagOrWidget ?tagOrURL?
 135 ##      Creates a tag for an URL to allow you to easily reference the URL
 136 ##      where URLs are required in other methods for this dialog.
 137 ##      If a widget pathname is specified as the tagOrWidget, then that
 138 ##      will become a tag that will load the specified URL when the help
 139 ##      binding is activated (if -binding is specified) which uses load.
 140 ##      If tagOrURL=={}, the tagOrWidget id is removed.
 141 ##      If it is not specified, the tagOrWidget link is returned.
 142 ##      A subst will be done on the tagOrURL at load time, so be careful
 143 ##      to escape special characters if you don't want them interpreted.
 144 ##      No subst will be done during the link operation though.
 145 ##
 146 ## load tagOrURL
 147 ##      Launches the HTML viewer with the specified tagOrURL.  A gettag
 148 ##      call is done of the tagOrURL link.
 149 ##
 150 ## NAMESPACE & STATE
 151 ##      The megawidget creates a global array with the classname, and a
 152 ## global array which is the name of each megawidget created.  The latter
 153 ## array is deleted when the megawidget is destroyed.
 154 ##      The procedure help and those beginning with Help are
 155 ## used.  Also, when a widget is created, commands named .$widgetname
 156 ## and Help$widgetname are created.
 157 ##
 158 ## EXAMPLE USAGE:
 159 if 0 {
 160     help .h -label "Tiger Help" -buttons {
 161         {Index    index}
 162         {Contents http://www.acm.org/}
 163     }
 164     .h link index http://www.altavista.digital.com/
 165     pack .h -fill both -exp 1
 166 }
 167 ##------------------------------------------------------------------------
 168
 169 #package require Tk
 170 #package require Megawidget 1.0
 171 #package require Bookmarks 1.0
 172 #package require WWW 1.0
 173
 174 #package provide Help 1.0
 175
 176 array set Help {
 177     type        frame
 178     base        frame
 179
 180     -executable {executable     Executable      \
 181             {{exec netscape -remote "openURL(%s)"} {exec netscape "%s" &}}}
 182     -label      {label          Label           {}}
 183     -binding    {binding        Binding         {}}
 184     -buttons    {buttons        Buttons         {}}
 185     -inherit    {inherit        Inherit         1}
 186     -subst      {subst          Subst           1}
 187 }
 188
 189 if {[string match windows $tcl_platform(platform)]} {
 190     set Help(-executable) {executable Executable {{exec netscape "%s" &}}}
 191 }
 192
 193 if {[info exists env(NETSCAPE_PATH)]} {
 194     regsub -all netscape $Help(-executable) \
 195             $env(NETSCAPE_PATH) \
 196             Help(-executable)
 197 } elseif {[string match windows $tcl_platform(platform)]} {
 198     regsub -all netscape $Help(-executable) \
 199             {"c:/program files/netscape/navigator/program/netscape.exe"} \
 200             Help(-executable)
 201 }
 202
 203 array set HelpDialog {
 204     type                toplevel
 205     base                help
 206     components          {{button dismiss} {frame separator}}
 207
 208     -dismisstext        {dismisstext    DismissText     Dismiss}
 209     -title              {title          Title           "Help"}
 210 }
 211 ## For the indexer to pick up
 212 proc Help args {}
 213 proc help args {}
 214 proc HelpDialog args {}
 215 proc helpdialog args {}
 216 proc help_dialog args {}
 217 widget create Help
 218 widget create HelpDialog
 219 interp alias {} help_dialog {} HelpDialog
 220
 221 ;proc HelpDialog:construct {w} {
 222     upvar \#0 $w data
 223     global $w
 224     wm title $w $data(-title)
 225
 226     $data(separator) configure -height 2 -relief ridge -bd 2
 227     $data(dismiss) configure -textvariable ${w}(-dismisstext) \
 228             -command [list $w hide]
 229
 230     grid $data(help) -in $w -sticky news
 231     grid $data(separator) -in $w -sticky ew
 232     grid $data(dismiss) -padx 4 -pady 2 -sticky ew
 233     grid columnconfig $w 0 -weight 1
 234     grid rowconfig $w 0 -weight 1
 235 }
 236
 237 ;proc HelpDialog:configure {w args} {
 238     upvar \#0 $w data
 239     set truth {^(1|yes|true|on)$}
 240     foreach {key val} $args {
 241         switch -- $key {
 242             -title      { wm title $w $val }
 243         }
 244         set data($key) $val
 245     }
 246 }
 247
 248 ;proc HelpDialog_hide w { if {[winfo exists $w]} {wm withdraw $w} }
 249
 250 ;proc HelpDialog_show w { if {[winfo exists $w]} {wm deiconify $w} }
 251
 252 ;proc Help:construct {w} {
 253     upvar \#0 $w data
 254
 255     ## Private variables
 256     array set data [list \
 257             buttonframe $w.bf \
 258             hierframe   $w.hf \
 259             labelframe  $w.lf \
 260             label       $w.lf.lbl \
 261             hierarchy   $w.hf.h \
 262             ]
 263
 264     ## Label Frame
 265     frame $data(labelframe)
 266     pack [label $data(label) -textvar $w\(-label\)]
 267     pack [frame $data(labelframe).sep -height 2 -relief ridge -bd 2] -fill x
 268     if {[string comp {} $data(-label)]} { pack $data(labelframe) -fill x }
 269
 270     ## Button Frame
 271     pack [frame $data(buttonframe)] -fill x
 272     Help:buttons $w $data(buttonframe) $data(-buttons)
 273
 274     ## Hierarchy (Bookmark) Frame
 275     pack [frame $data(hierframe)] -fill both -exp 1
 276 }
 277
 278 ;proc Help_subwidget {w widget} {
 279     upvar \#0 $w data
 280     switch -- $widget {
 281         base - container - label - hierarchy { return $data($widget) }
 282         default { return -code error "No $data(class) subwidget \"$widget\"" }
 283     }
 284 }
 285
 286 ;proc Help:configure {w args} {
 287     upvar \#0 $w data
 288     set truth {^(1|yes|true|on)$}
 289     foreach {key val} $args {
 290         switch -- $key {
 291             -binding    {
 292                 if {[string comp {} $data($key)]} { bind all $data($key) {} }
 293                 if {[string comp {} $val]} {
 294                     bind all $val "Help_load $w \[winfo contain %X %Y\] 0"
 295                 }
 296                 set data($key) $val
 297             }
 298             -buttons    {
 299                 set data($key) $val
 300                 Help:buttons $w $data(buttonframe) $val
 301             }
 302             -executable { set data($key) $val }
 303             -inherit    { set data($key) [regexp -nocase $truth $val] }
 304             -label      {
 305                 set data($key) $val
 306                 if {[string comp {} $val]} {
 307                     pack $data(labelframe) -fill x -before $data(buttonframe)
 308                 } else {
 309                     pack forget $data(labelframe)
 310                 }
 311             }
 312         }
 313     }
 314 }
 315
 316 ;proc Help:destroy w {
 317     upvar \#0 $w data
 318     if {[string comp {} $data(-binding)]} { bind all $data(-binding) {} }
 319 }
 320
 321 ;proc Help:buttons {w f btns} {
 322     catch {eval destroy [winfo children $f]}
 323     set i 0
 324     foreach btn $btns {
 325         foreach {b tag list} $btn break
 326         button $f.[incr i] -text $b -command "Help_load $w $tag"
 327         if {[regexp -nocase {^(1|yes|true|on)$} $list]} {
 328             ## tagOrURL represents bookmark page for hierarchy list
 329         }
 330         pack $f.$i -fill x -side left
 331     }
 332 }
 333
 334 ;proc Help_link {w tag {url NULL}} {
 335     upvar \#0 $w data
 336     if {[string comp NULL $url]} {
 337         set i 100
 338         while {[info exists data(@$url)] && $i<100} {
 339             set url $data(@$url)
 340             incr i
 341         }
 342         set data(@$tag) $url
 343     } elseif {[string match {} $url]} {
 344         catch {unset data(@$tag)}
 345         return
 346     }
 347     if {[info exists data(@$tag)]} {
 348         return $data(@$tag)
 349     } else {
 350         return -code error "no help link \"$tag\" defined"
 351     }
 352 }
 353
 354 ;proc Help_gettag {w tag} {
 355     upvar \#0 $w data
 356     set found 0
 357     while {[info exists data(@$tag)] && $found<100} {
 358         incr found
 359         if {$data(-subst)} {
 360             set tag [uplevel \#0 [list subst $data(@$tag)]]
 361         } else {
 362             set tag $data(@$tag)
 363         }
 364     }
 365     if {$found} {
 366         return $tag
 367     } elseif {$data(-inherit) && [winfo exists $tag]} {
 368         while {![info exists data(@$tag)] && [string comp . $tag]} {
 369             set tag [winfo parent $tag]
 370         }
 371         if {[info exists data(@$tag)]} { return $data(@$tag) }
 372     }
 373     return
 374 }
 375
 376 ;proc Help_load {w url {complain 1}} {
 377     upvar \#0 $w data
 378     set link [Help_gettag $w $url]
 379     if {[string comp {} $link]} {
 380         Help:load $w $link
 381     } elseif {[string match http:/* $url] || [string match file:/* $url]} {
 382         Help:load $w $url
 383     } elseif {$complain} {
 384         return -code error "\"$url\" not recognized as proper URL or help link"
 385     }
 386 }
 387
 388 ;proc Help:load {w url} {
 389     upvar \#0 $w data
 390     regsub -all {([^\\])%s} $data(-executable) "\\1$url" cmds
 391     set failed 1
 392     foreach cmd $cmds {
 393         if {![catch $cmd]} {
 394             set failed 0
 395             break
 396         }
 397     }
 398     if {$failed} {
 399         tk_dialog $w.dialog "Failed to load URL." \
 400                 "Failed to load URL via any of the commands:\n$cmds\
 401                 \nMake sure the command exists and is in your path." \
 402                 warning 0 OK
 403     }
 404 }
 405