distrib/share/tcl/help.tcl

   1 #
   2 # help.tcl --
   3 #
   4 # Tcl help command. (see TclX manual)
   5 #
   6 #------------------------------------------------------------------------------
   7 # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
   8 #
   9 # Permission to use, copy, modify, and distribute this software and its
  10 # documentation for any purpose and without fee is hereby granted, provided
  11 # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  12 # Mark Diekhans make no representations about the suitability of this
  13 # software for any purpose.  It is provided "as is" without express or
  14 # implied warranty.
  15 #------------------------------------------------------------------------------
  16 # The help facility is based on a hierarchical tree of subjects (directories)
  17 # and help pages (files).  There is a virtual root to this tree. The root
  18 # being the merger of all "help" directories found along the $auto_path
  19 # variable.
  20 #------------------------------------------------------------------------------
  21 # $Id: help.tcl,v 1.2 2007/11/23 10:59:34 anthony Exp $
  22 #------------------------------------------------------------------------------
  23 #
  24
  25 #@package: TclX-help help helpcd helppwd apropos
  26
  27 namespace eval ::help {
  28     variable curSubject "/"
  29 }
  30
  31 #------------------------------------------------------------------------------
  32 # Help command.
  33
  34 proc help {{what {}}} {
  35     variable ::help::lineCnt 0
  36
  37     # Special case "help help", so we can get it at any level.
  38
  39     if {($what == "help") || ($what == "?")} {
  40         help::HelpOnHelp
  41         return
  42     }
  43
  44     set pathList [help::ConvertPath $what]
  45     if {[file isfile [lindex $pathList 0]]} {
  46         help::DisplayPage [lindex $pathList 0]
  47         return
  48     }
  49
  50     help::ListSubject $what $pathList subjects pages
  51     set relativeDir [help::RelativePath [lindex $pathList 0]]
  52
  53     if {[llength $subjects] != 0} {
  54         help::Display "\nSubjects available in $relativeDir:"
  55         help::DisplayColumns $subjects
  56     }
  57     if {[llength $pages] != 0} {
  58         help::Display "\nHelp pages available in $relativeDir:"
  59         help::DisplayColumns $pages
  60     }
  61 }
  62
  63
  64 #------------------------------------------------------------------------------
  65 # helpcd command.  The name of the new current directory is assembled from the
  66 # current directory and the argument.
  67
  68 proc helpcd {{dir /}} {
  69     variable ::help::curSubject
  70
  71     set pathName [lindex [help::ConvertPath $dir] 0]
  72
  73     if {![file isdirectory $pathName]} {
  74         error "\"$dir\" is not a subject" [list TCLXHELP NOTSUBJECT $dir]
  75     }
  76
  77     set ::help::curSubject [help::RelativePath $pathName]
  78     return
  79 }
  80
  81 #------------------------------------------------------------------------------
  82 # Helpcd main.
  83
  84 proc helppwd {} {
  85     variable ::help::curSubject
  86     puts "Current help subject: $::help::curSubject"
  87 }
  88
  89 #------------------------------------------------------------------------------
  90 # apropos command.  This search the
  91
  92 proc apropos {regexp} {
  93     variable ::help::lineCnt 0
  94     variable ::help::curSubject
  95
  96     set stop 0
  97     foreach dir [help::RootDirs] {
  98         foreach brief [glob -nocomplain $dir/*.brf] {
  99             set briefFH [open $brief]
 100             while {[gets $briefFH line] != -1} {
 101                 if {[regexp -nocase $regexp $line] == 1} {
 102                     set path [lindex $line 0]
 103                     set desc [lrange $line 1 end]
 104                     if {![help::Display [format "%s - %s" $path $desc]]} {
 105                         set stop 1
 106                     }
 107                 }
 108             }
 109             close $briefFH
 110             if {$stop} break
 111         }
 112         if {$stop} break
 113     }
 114 }
 115
 116 ##
 117 ## Private Helper Routines
 118 ##
 119
 120 #----------------------------------------------------------------------
 121 # Return a list of help root directories.
 122
 123 proc ::help::RootDirs {} {
 124     global auto_path
 125     set roots {}
 126     foreach dir $auto_path {
 127         if {[file isdirectory $dir/help]} {
 128             lappend roots $dir/help
 129         }
 130     }
 131     return $roots
 132 }
 133
 134 #--------------------------------------------------------------------------
 135 # Take a path name which might have "." and ".." elements and flatten them
 136 # out.  Also removes trailing and adjacent "/", unless its the only
 137 # character.
 138
 139 proc ::help::FlattenPath pathName {
 140     set newPath {}
 141     foreach element [split $pathName /] {
 142         if {"$element" == "." || ![string compare "" $element]} continue
 143
 144         if {"$element" == ".."} {
 145             if {[llength [join $newPath /]] == 0} {
 146                 error "Help: name goes above subject directory root" {} \
 147                     [list TCLXHELP NAMEABOVEROOT $pathName]
 148             }
 149             set index [expr [llength $newPath]-1]
 150             set newPath [lreplace $newPath $index $index]
 151             continue
 152         }
 153         lappend newPath $element
 154     }
 155     set newPath [join $newPath /]
 156
 157     # Take care of the case where we started with something line "/" or "/."
 158
 159     if {("$newPath" == "") && [string match "/*" $pathName]} {
 160         set newPath "/"
 161     }
 162
 163     return $newPath
 164 }
 165
 166 #--------------------------------------------------------------------------
 167 # Given a pathName relative to the virtual help root, convert it to a list
 168 # of real file paths.  A list is returned because the path could be "/",
 169 # returning a list of all roots. The list is returned in the same order of
 170 # the auto_path variable. If path does not start with a "/", it is take as
 171 # relative to the current help subject.  Note: The root directory part of
 172 # the name is not flattened.  This lets other commands pick out the part
 173 # relative to the one of the root directories.
 174
 175 proc ::help::ConvertPath pathName {
 176     variable curSubject
 177
 178     if {![string match "/*" $pathName]} {
 179         if {![string compare $curSubject "/"]} {
 180             set pathName "/$pathName"
 181         } else {
 182             set pathName "$curSubject/$pathName"
 183         }
 184     }
 185     set pathName [FlattenPath $pathName]
 186
 187     # If the virtual root is specified, return a list of directories.
 188
 189     if {$pathName == "/"} {
 190         return [RootDirs]
 191     }
 192
 193     # Not the virtual root find the first match.
 194
 195     foreach dir [RootDirs] {
 196         if {[file readable $dir/$pathName]} {
 197             return [list $dir/$pathName]
 198         }
 199     }
 200
 201     # Not found, try to find a file matching only the file tail,
 202     # for example if --> <helpDir>/tcl/control/if.
 203
 204     set fileTail [file tail $pathName]
 205     foreach dir [RootDirs] {
 206         set fileName [exec find $dir -name $fileTail | head -1]
 207         if {$fileName != {}} {
 208             return [list $fileName]
 209         }
 210     }
 211
 212     error "\"$pathName\" does not exist" {} \
 213         [list TCLXHELP NOEXIST $pathName]
 214 }
 215
 216 #--------------------------------------------------------------------------
 217 # Return the virtual root relative name of the file given its absolute
 218 # path.  The root part of the path should not have been flattened, as we
 219 # would not be able to match it.
 220
 221 proc ::help::RelativePath pathName {
 222     foreach dir [RootDirs] {
 223         if {[string range $pathName 0 [expr [string length $dir] - 1]] == $dir} {
 224             set name [string range $pathName [string length $dir] end]
 225             if {$name == ""} {set name /}
 226             return $name
 227         }
 228     }
 229     if {![info exists found]} {
 230         error "problem translating \"$pathName\"" {} [list TCLXHELP INTERROR]
 231     }
 232 }
 233
 234 #--------------------------------------------------------------------------
 235 # Given a list of path names to subjects generated by ConvertPath, return
 236 # the contents of the subjects.  Two lists are returned, subjects under
 237 # that subject and a list of pages under the subject.  Both lists are
 238 # returned sorted.  This merges all the roots into a virtual root.
 239 # pathName is the string that was passed to ConvertPath and is used for
 240 # error reporting.  *.brk files are not returned.
 241
 242 proc ::help::ListSubject {pathName pathList subjectsVar pagesVar} {
 243     upvar $subjectsVar subjects $pagesVar pages
 244
 245     set subjects {}
 246     set pages {}
 247     set foundDir 0
 248     foreach dir $pathList {
 249         if {![file isdirectory $dir] || ![string compare [file tail $dir] CVS]} continue
 250         set foundDir 1
 251         foreach file [glob -nocomplain $dir/*] {
 252             if {[lsearch {.brf .orig .diff .rej} [file extension $file]] \
 253                     >= 0} continue
 254             if [file isdirectory $file] {
 255                 lappend subjects [file tail $file]/
 256             } else {
 257                 lappend pages [file tail $file]
 258             }
 259         }
 260     }
 261     if {!$foundDir} {
 262         if {![string compare $pathName /]} {
 263             global auto_path
 264             error "no \"help\" directories found on auto_path ($auto_path)" {} \
 265                 [list TCLXHELP NOHELPDIRS]
 266         } else {
 267             error "\"$pathName\" is not a subject" {} \
 268                 [list TCLXHELP NOTSUBJECT $pathName]
 269         }
 270     }
 271     set subjects [lsort $subjects]
 272     set pages [lsort $pages]
 273     return {}
 274 }
 275
 276 #--------------------------------------------------------------------------
 277 # Display a line of output, pausing waiting for input before displaying if
 278 # the screen size has been reached.  Return 1 if output is to continue,
 279 # return 0 if no more should be outputed, indicated by input other than
 280 # return.
 281 #
 282
 283 proc ::help::Display line {
 284     variable lineCnt
 285     if {$lineCnt >= 23} {
 286         set lineCnt 0
 287         puts -nonewline stdout ":"
 288         flush stdout
 289         gets stdin response
 290         if {[string compare "" $response]} {
 291             return 0}
 292     }
 293     puts stdout $line
 294     incr lineCnt
 295 }
 296
 297 #--------------------------------------------------------------------------
 298 # Display a help page (file).
 299
 300 proc ::help::DisplayPage filePath {
 301
 302     set inFH [open $filePath r]
 303         while {[gets $inFH fileBuf] >= 0} {
 304             if {![Display $fileBuf]} {
 305                 break
 306             }
 307         }
 308         close $inFH
 309 }
 310
 311 #--------------------------------------------------------------------------
 312 # Display a list of file names in a column format. This use columns of 14
 313 # characters 3 blanks.
 314
 315 proc ::help::DisplayColumns {nameList} {
 316     set count 0
 317     set outLine ""
 318     foreach name $nameList {
 319         if {$count == 0} {
 320             append outLine "   "
 321         }
 322         append outLine $name
 323         if {[incr count] < 4} {
 324             set padLen [expr 17-[string length $name]]
 325             if {$padLen < 3} {
 326                 set padLen 3}
 327                 set pad ""
 328                 for {set i 0} {$i < $padLen} {incr i 1} {
 329                     append pad " "
 330                 }
 331             append outLine $pad
 332         } else {
 333             if {![Display $outLine]} {
 334                 return}
 335             set outLine ""
 336             set count 0
 337         }
 338     }
 339     if {$count != 0} {
 340         Display [string trimright $outLine]}
 341     return
 342 }
 343
 344
 345 #--------------------------------------------------------------------------
 346 # Display help on help, the first occurance of a help page called "help" in
 347 # the help root.
 348
 349 proc ::help::HelpOnHelp {} {
 350     set helpPage [lindex [ConvertPath /help] 0]
 351     if {![string compare "" $helpPage]} {
 352         error "No help page on help found" {} \
 353             [list TCLXHELP NOHELPPAGE]
 354     }
 355     DisplayPage $helpPage
 356 }
 357