????
Current Path : /proc/thread-self/root/usr/lib64/tcl8.5/tclx8.4/ |
Current File : //proc/thread-self/root/usr/lib64/tcl8.5/tclx8.4/help.tcl |
# # help.tcl -- # # Tcl help command. (see TclX manual) # #------------------------------------------------------------------------------ # Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. Karl Lehenbauer and # Mark Diekhans make no representations about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. #------------------------------------------------------------------------------ # The help facility is based on a hierarchical tree of subjects (directories) # and help pages (files). There is a virtual root to this tree. The root # being the merger of all "help" directories found along the $auto_path # variable. #------------------------------------------------------------------------------ # $Id: help.tcl,v 1.2 2004/11/23 05:54:15 hobbs Exp $ #------------------------------------------------------------------------------ # #@package: TclX-help help helpcd helppwd apropos namespace eval ::tclx { namespace export help helpcd helppwd apropos } namespace eval ::tclx::help { variable curSubject "/" } #------------------------------------------------------------------------------ # Help command. proc ::tclx::help {{what {}}} { variable ::tclx::help::lineCnt 0 # Special case "help help", so we can get it at any level. if {($what == "help") || ($what == "?")} { tclx::help::HelpOnHelp return } set pathList [tclx::help::ConvertPath $what] if {[file isfile [lindex $pathList 0]]} { tclx::help::DisplayPage [lindex $pathList 0] return } tclx::help::ListSubject $what $pathList subjects pages set relativeDir [tclx::help::RelativePath [lindex $pathList 0]] if {[llength $subjects] != 0} { tclx::help::Display "\nSubjects available in $relativeDir:" tclx::help::DisplayColumns $subjects } if {[llength $pages] != 0} { tclx::help::Display "\nHelp pages available in $relativeDir:" tclx::help::DisplayColumns $pages } } #------------------------------------------------------------------------------ # helpcd command. The name of the new current directory is assembled from the # current directory and the argument. proc ::tclx::helpcd {{dir /}} { variable ::tclx::help::curSubject set pathName [lindex [tclx::help::ConvertPath $dir] 0] if {![file isdirectory $pathName]} { error "\"$dir\" is not a subject" [list TCLXHELP NOTSUBJECT $dir] } set ::tclx::help::curSubject [tclx::help::RelativePath $pathName] return } #------------------------------------------------------------------------------ # Helpcd main. proc ::tclx::helppwd {} { variable ::tclx::help::curSubject echo "Current help subject: $::tclx::help::curSubject" } #------------------------------------------------------------------------------ # apropos command. This search the proc ::tclx::apropos {regexp} { variable ::tclx::help::lineCnt 0 variable ::tclx::help::curSubject set ch [scancontext create] scanmatch -nocase $ch $regexp { set path [lindex $matchInfo(line) 0] set desc [lrange $matchInfo(line) 1 end] if {![tclx::help::Display [format "%s - %s" $path $desc]]} { set stop 1 return } } set stop 0 foreach dir [tclx::help::RootDirs] { foreach brief [glob -nocomplain $dir/*.brf] { set briefFH [open $brief] try_eval { scanfile $ch $briefFH } {} { close $briefFH } if {$stop} break } if {$stop} break } scancontext delete $ch } ## ## Private Helper Routines ## #---------------------------------------------------------------------- # Return a list of help root directories. proc ::tclx::help::RootDirs {} { global auto_path set roots {} foreach dir $auto_path { if {[file isdirectory $dir/help]} { lappend roots $dir/help } } return $roots } #-------------------------------------------------------------------------- # Take a path name which might have "." and ".." elements and flatten them # out. Also removes trailing and adjacent "/", unless its the only # character. proc ::tclx::help::FlattenPath pathName { set newPath {} foreach element [split $pathName /] { if {"$element" == "." || [lempty $element]} continue if {"$element" == ".."} { if {[llength [join $newPath /]] == 0} { error "Help: name goes above subject directory root" {} \ [list TCLXHELP NAMEABOVEROOT $pathName] } lvarpop newPath [expr [llength $newPath]-1] continue } lappend newPath $element } set newPath [join $newPath /] # Take care of the case where we started with something line "/" or "/." if {("$newPath" == "") && [string match "/*" $pathName]} { set newPath "/" } return $newPath } #-------------------------------------------------------------------------- # Given a pathName relative to the virtual help root, convert it to a list # of real file paths. A list is returned because the path could be "/", # returning a list of all roots. The list is returned in the same order of # the auto_path variable. If path does not start with a "/", it is take as # relative to the current help subject. Note: The root directory part of # the name is not flattened. This lets other commands pick out the part # relative to the one of the root directories. proc ::tclx::help::ConvertPath pathName { variable curSubject if {![string match "/*" $pathName]} { if {[cequal $curSubject "/"]} { set pathName "/$pathName" } else { set pathName "$curSubject/$pathName" } } set pathName [FlattenPath $pathName] # If the virtual root is specified, return a list of directories. if {$pathName == "/"} { return [RootDirs] } # Not the virtual root find the first match. foreach dir [RootDirs] { if {[file readable $dir/$pathName]} { return [list $dir/$pathName] } } # Not found, try to find a file matching only the file tail, # for example if --> <helpDir>/tcl/control/if. set fileTail [file tail $pathName] foreach dir [RootDirs] { set fileName [exec find $dir -name $fileTail | head -1] if {$fileName != {}} { return [list $fileName] } } error "\"$pathName\" does not exist" {} \ [list TCLXHELP NOEXIST $pathName] } #-------------------------------------------------------------------------- # Return the virtual root relative name of the file given its absolute # path. The root part of the path should not have been flattened, as we # would not be able to match it. proc ::tclx::help::RelativePath pathName { foreach dir [RootDirs] { if {[csubstr $pathName 0 [clength $dir]] == $dir} { set name [csubstr $pathName [clength $dir] end] if {$name == ""} {set name /} return $name } } if {![info exists found]} { error "problem translating \"$pathName\"" {} [list TCLXHELP INTERROR] } } #-------------------------------------------------------------------------- # Given a list of path names to subjects generated by ConvertPath, return # the contents of the subjects. Two lists are returned, subjects under # that subject and a list of pages under the subject. Both lists are # returned sorted. This merges all the roots into a virtual root. # pathName is the string that was passed to ConvertPath and is used for # error reporting. *.brk files are not returned. proc ::tclx::help::ListSubject {pathName pathList subjectsVar pagesVar} { upvar $subjectsVar subjects $pagesVar pages set subjects {} set pages {} set foundDir 0 foreach dir $pathList { if {![file isdirectory $dir] || [cequal [file tail $dir] CVS]} continue set foundDir 1 foreach file [glob -nocomplain $dir/*] { if {[lsearch {.brf .orig .diff .rej} [file extension $file]] \ >= 0} continue if [file isdirectory $file] { lappend subjects [file tail $file]/ } else { lappend pages [file tail $file] } } } if {!$foundDir} { if {[cequal $pathName /]} { global auto_path error "no \"help\" directories found on auto_path ($auto_path)" {} \ [list TCLXHELP NOHELPDIRS] } else { error "\"$pathName\" is not a subject" {} \ [list TCLXHELP NOTSUBJECT $pathName] } } set subjects [lsort $subjects] set pages [lsort $pages] return {} } #-------------------------------------------------------------------------- # Display a line of output, pausing waiting for input before displaying if # the screen size has been reached. Return 1 if output is to continue, # return 0 if no more should be outputed, indicated by input other than # return. # proc ::tclx::help::Display line { variable lineCnt if {$lineCnt >= 23} { set lineCnt 0 puts -nonewline stdout ":" flush stdout gets stdin response if {![lempty $response]} { return 0} } puts stdout $line incr lineCnt } #-------------------------------------------------------------------------- # Display a help page (file). proc ::tclx::help::DisplayPage filePath { set inFH [open $filePath r] try_eval { while {[gets $inFH fileBuf] >= 0} { if {![Display $fileBuf]} { break } } } {} { close $inFH } } #-------------------------------------------------------------------------- # Display a list of file names in a column format. This use columns of 14 # characters 3 blanks. proc ::tclx::help::DisplayColumns {nameList} { set count 0 set outLine "" foreach name $nameList { if {$count == 0} { append outLine " " } append outLine $name if {[incr count] < 4} { set padLen [expr 17-[clength $name]] if {$padLen < 3} { set padLen 3} append outLine [replicate " " $padLen] } else { if {![Display $outLine]} { return} set outLine "" set count 0 } } if {$count != 0} { Display [string trimright $outLine]} return } #-------------------------------------------------------------------------- # Display help on help, the first occurance of a help page called "help" in # the help root. proc ::tclx::help::HelpOnHelp {} { set helpPage [lindex [ConvertPath /help] 0] if {[lempty $helpPage]} { error "No help page on help found" {} \ [list TCLXHELP NOHELPPAGE] } DisplayPage $helpPage }