Return to help.tcl CVS log

Up to [Micropolis - Activity] / micropolis / src / tclx / tclsrc

Annotation of micropolis/src/tclx/tclsrc/help.tcl, revision 1.1

1.1     ! root        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) {}

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.