git.zerfleddert.de Git - micropolis/blob - src/tclx/tclsrc/help.tcl

   1 #
   2 # help.tcl --
   3 #
   4 # Tcl help command. (see TclX manual)
   5 #
   6 #------------------------------------------------------------------------------
   7 # Copyright 1992 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 # $Id: help.tcl,v 2.0 1992/10/16 04:52:01 markd Rel $
  17 #------------------------------------------------------------------------------
  18 #
  19
  20 #@package: TclX-help help helpcd helppwd apropos
  21
  22 #------------------------------------------------------------------------------
  23 # Take a path name which might have . and .. elements and flatten them out.
  24
  25 proc help:flattenPath {pathName} {
  26     set newPath {}
  27     foreach element [split $pathName /] {
  28         if {"$element" == "."} {
  29            continue
  30         }
  31         if {"$element" == ".."} {
  32             if {[llength [join $newPath /]] == 0} {
  33                 error "Help: name goes above subject directory root"}
  34             lvarpop newPath [expr [llength $newPath]-1]
  35             continue
  36         }
  37         lappend newPath $element
  38     }
  39     set newPath [join $newPath /]
  40
  41     # Take care of the case where we started with something line "/" or "/."
  42
  43     if {("$newPath" == "") && [string match "/*" $pathName]} {
  44         set newPath "/"}
  45
  46     return $newPath
  47 }
  48
  49 #------------------------------------------------------------------------------
  50 # Take the help current directory and a path and evaluate it into a help root-
  51 # based path name.
  52
  53 proc help:EvalPath {pathName} {
  54     global TCLENV
  55
  56     if {![string match "/*" $pathName]} {
  57         if {"$pathName" == ""} {
  58             return $TCLENV(help:curDir)}
  59         if {"$TCLENV(help:curDir)" == "/"} {
  60             set pathName "/$pathName"
  61         } else {
  62             set pathName "$TCLENV(help:curDir)/$pathName"
  63         }
  64     }
  65     set pathName [help:flattenPath $pathName]
  66     if {[string match "*/" $pathName] && ($pathName != "/")} {
  67         set pathName [csubstr $pathName 0 [expr [length $pathName]-1]]}
  68
  69     return $pathName
  70 }
  71
  72 #------------------------------------------------------------------------------
  73 # Display a line of output, pausing waiting for input before displaying if the
  74 # screen size has been reached.  Return 1 if output is to continue, return
  75 # 0 if no more should be outputed, indicated by input other than return.
  76 #
  77
  78 proc help:Display {line} {
  79     global TCLENV
  80     if {$TCLENV(help:lineCnt) >= 23} {
  81         set TCLENV(help:lineCnt) 0
  82         puts stdout ":" nonewline
  83         flush stdout
  84         gets stdin response
  85         if {![lempty $response]} {
  86             return 0}
  87     }
  88     puts stdout $line
  89     incr TCLENV(help:lineCnt)
  90 }
  91
  92 #------------------------------------------------------------------------------
  93 # Display a file.
  94
  95 proc help:DisplayFile {filepath} {
  96
  97     set inFH [open $filepath r]
  98     while {[gets $inFH fileBuf] >= 0} {
  99         if {![help:Display $fileBuf]} {
 100             break}
 101     }
 102     close $inFH
 103
 104 }
 105
 106 #------------------------------------------------------------------------------
 107 # Procedure to return contents of a directory.  A list is returned, consisting
 108 # of two lists.  The first list are all the directories (subjects) in the
 109 # specified directory.  The second is all of the help files.  Eash sub-list
 110 # is sorted in alphabetical order.
 111 #
 112
 113 proc help:ListDir {dirPath} {
 114     set dirList {}
 115     set fileList {}
 116     if {[catch {set dirFiles [glob $dirPath/*]}] != 0} {
 117         error "No files in subject directory: $dirPath"}
 118     foreach fileName $dirFiles {
 119         if [file isdirectory $fileName] {
 120             lappend dirList "[file tail $fileName]/"
 121         } else {
 122             lappend fileList [file tail $fileName]
 123         }
 124     }
 125    return [list [lsort $dirList] [lsort $fileList]]
 126 }
 127
 128 #------------------------------------------------------------------------------
 129 # Display a list of file names in a column format. This use columns of 14
 130 # characters 3 blanks.
 131
 132 proc help:DisplayColumns {nameList} {
 133     set count 0
 134     set outLine ""
 135     foreach name $nameList {
 136         if {$count == 0} {
 137             append outLine "   "}
 138         append outLine $name
 139         if {[incr count] < 4} {
 140             set padLen [expr 17-[clength $name]]
 141             if {$padLen < 3} {
 142                set padLen 3}
 143             append outLine [replicate " " $padLen]
 144         } else {
 145            if {![help:Display $outLine]} {
 146                return}
 147            set outLine ""
 148            set count 0
 149         }
 150     }
 151     if {$count != 0} {
 152         help:Display $outLine}
 153     return
 154 }
 155
 156
 157 #------------------------------------------------------------------------------
 158 # Help command main.
 159
 160 proc help {{subject {}}} {
 161     global TCLENV
 162
 163     set TCLENV(help:lineCnt) 0
 164
 165     # Special case "help help", so we can get it at any level.
 166
 167     if {($subject == "help") || ($subject == "?")} {
 168         help:DisplayFile "$TCLENV(help:root)/help"
 169         return
 170     }
 171
 172     set request [help:EvalPath $subject]
 173     set requestPath "$TCLENV(help:root)$request"
 174
 175     if {![file exists $requestPath]} {
 176         error "Help:\"$request\" does not exist"}
 177
 178     if [file isdirectory $requestPath] {
 179         set dirList [help:ListDir $requestPath]
 180         set subList  [lindex $dirList 0]
 181         set fileList [lindex $dirList 1]
 182         if {[llength $subList] != 0} {
 183             help:Display "\nSubjects available in $request:"
 184             help:DisplayColumns $subList
 185         }
 186         if {[llength $fileList] != 0} {
 187             help:Display "\nHelp files available in $request:"
 188             help:DisplayColumns $fileList
 189         }
 190     } else {
 191         help:DisplayFile $requestPath
 192     }
 193     return
 194 }
 195
 196
 197 #------------------------------------------------------------------------------
 198 # Helpcd main.
 199 #
 200 # The name of the new current directory is assembled from the current
 201 # directory and the argument.  The name will be flatten and any trailing
 202 # "/" will be removed, unless the name is just "/".
 203
 204 proc helpcd {{dir /}} {
 205     global TCLENV
 206
 207     set request [help:EvalPath $dir]
 208     set requestPath "$TCLENV(help:root)$request"
 209
 210     if {![file exists $requestPath]} {
 211         error "Helpcd: \"$request\" does not exist"}
 212
 213     if {![file isdirectory $requestPath]} {
 214         error "Helpcd: \"$request\" is not a directory"}
 215
 216     set TCLENV(help:curDir) $request
 217     return
 218 }
 219
 220 #------------------------------------------------------------------------------
 221 # Helpcd main.
 222
 223 proc helppwd {} {
 224         global TCLENV
 225         echo "Current help subject directory: $TCLENV(help:curDir)"
 226 }
 227
 228 #==============================================================================
 229 #     Tcl apropos command.  (see Tcl shell manual)
 230 #------------------------------------------------------------------------------
 231
 232 proc apropos {name} {
 233     global TCLENV
 234
 235     set TCLENV(help:lineCnt) 0
 236
 237     set aproposCT [scancontext create]
 238     scanmatch -nocase $aproposCT $name {
 239         set path [lindex $matchInfo(line) 0]
 240         set desc [lrange $matchInfo(line) 1 end]
 241         if {![help:Display [format "%s - %s" $path $desc]]} {
 242             return}
 243     }
 244     foreach brief [glob -nocomplain $TCLENV(help:root)/*.brf] {
 245         set briefFH [open $brief]
 246         scanfile $aproposCT $briefFH
 247         close $briefFH
 248     }
 249     scancontext delete $aproposCT
 250 }
 251
 252 #------------------------------------------------------------------------------
 253 # One time initialization done when the file is sourced.
 254 #
 255 global TCLENV TCLPATH
 256
 257 set TCLENV(help:root) [searchpath $TCLPATH help]
 258 set TCLENV(help:curDir) "/"
 259 set TCLENV(help:outBuf) {}