1# 2# help.test 3# 4# Tests for the help subsystem. Help must be build first. If help files 5# change, thest tests may have to be changed. 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# $Id: help.test,v 1.4 2005/03/25 19:59:44 hobbs Exp $ 17#------------------------------------------------------------------------------ 18# 19 20if {[cequal [info procs Test] {}]} { 21 source [file join [file dirname [info script]] testlib.tcl] 22} 23 24if [cequal $tcl_platform(platform) windows] { 25 echo " * The help tests have not been ported to Win32" 26 return 27} 28 29TestRemove HELP.PRG 30 31# 32# Only run help test if help has been built. 33# 34if {[info exists ::env(TCLX_HELP_DIR)] 35 && [file exists $::env(TCLX_HELP_DIR)]} { 36 set HELPDIR $::env(TCLX_HELP_DIR) 37} else { 38 set HELPDIR [file join $tclx_library help] 39} 40if [cequal [glob -nocomplain [file join $HELPDIR *]] ""] { 41 puts "*************************************************************" 42 puts "No help pages in: " 43 puts " $HELPDIR" 44 puts "Help tests will be skipped." 45 puts "*************************************************************" 46 return 47} 48 49#------------------------------------------------------------------------------ 50# Read a line from the server, set an alarm to make sure it doesn't hang. 51# Handle pager `:' prompts specially. 52proc ReadServer {} { 53 global helpServerFH 54 55 alarm 45 56 if {[gets $helpServerFH line] < 0} { 57 alarm 0 58 error "EOF from help server" 59 } 60 alarm 0 61 return $line 62} 63 64#------------------------------------------------------------------------------ 65# Eat a prompt line from the help server. 66 67proc EatServerPrompt {} { 68 set line [ReadServer] 69 if ![cequal $line "===HELPSERVER==="] { 70 error "unexpected output from help server: `$line'" 71 } 72} 73 74#------------------------------------------------------------------------------ 75# Send a command to the help server and return the output. The help server 76# output will be bracketed with commands to mark the beginning and ending. 77# An extra newline is always queued to continue the help pager. The prompt of 78# the pager will be removed from the output. This assumes that the output has 79# no lines starting with `:'. 80# 81proc HelpSend {cmd pagerCntVar} { 82 global helpServerFH 83 upvar $pagerCntVar pagerCnt 84 85 puts $helpServerFH $cmd 86 puts $helpServerFH "" ;# Just a new line.. 87 88 set pagerCnt 0 89 set results {} 90 91 # Read lines of the output. 92 while 1 { 93 set line [ReadServer] 94 if [cequal [cindex $line 0] ":"] { 95 set line [crange $line 1 end] 96 incr pagerCnt 97 puts $helpServerFH "" ;# Just a new line 98 } 99 if [cequal "$line" "===HELPSERVER==="] { 100 break 101 } 102 append results $line "\n" 103 } 104 # Eat the extra prompt caused by the typed-ahead newline 105 EatServerPrompt 106 107 return $results 108} 109 110# 111# Create the help server process, which will execute the commands, 112# with stdin and stdout redirected to pipes. 113# 114global helpServerFH 115 116set fh [open HELP.PRG w] 117puts $fh { 118 package require Tclx 119 namespace import -force tclx::help* tclx::apropos 120 fconfigure stdout -buffering none 121 fconfigure stderr -buffering none 122 commandloop -interactive on -prompt1 {subst "===HELPSERVER===\n"} \ 123 -prompt2 {error "Help server incomplete cmd"} 124 error "Help server got eof" 125} 126close $fh 127 128set helpServerFH [open "|[list $::tcltest::tcltest HELP.PRG]" r+] 129fconfigure $helpServerFH -buffering none 130 131# 132# An alarm will be set when talking to the server uncase it doesn't talk back 133# 134signal error SIGALRM 135 136# Nuke the first prompt 137EatServerPrompt 138 139# Now run the tests. 140 141 142Test help-1.1 {help tests} { 143 HelpSend "help" promptCnt 144} 0 { 145Subjects available in /: 146 tcl/ 147 148Help pages available in /: 149 help 150} 151 152Test help-1.1.1 {help tests} { 153 HelpSend "help tcl" promptCnt 154} 0 { 155Subjects available in /tcl: 156 control/ debug/ events/ files/ 157 filescan/ intl/ intro/ keyedlists/ 158 libraries/ lists/ math/ processes/ 159 signals/ sockets/ status/ strings/ 160 tclshell/ time/ variables/ 161} 162 163Test help-1.2 {help tests} { 164 HelpSend "helppwd" promptCnt 165} 0 {Current help subject: / 166} 167 168Test help-1.3 {help tests} { 169 HelpSend "helpcd tcl/filescan" promptCnt 170} 0 {} 171 172Test help-1.4 {help tests} { 173 HelpSend "helppwd" promptCnt 174} 0 {Current help subject: /tcl/filescan 175} 176 177Test help-1.5 {help tests} { 178 set result [HelpSend "help /tcl/lists/lassign" promptCnt] 179 set fh [open "$HELPDIR/tcl/lists/lassign"] 180 set expect [read $fh] 181 close $fh 182 set summary {} 183 if {"$expect" == "$result"} { 184 append summary "CORRECT" 185 } else { 186 append summary "DATA DOES NOT MATCH : $result" 187 } 188 if {$promptCnt == 0} { 189 append summary " : PROMPT OK" 190 } else { 191 append summary " : TOO MANY PROMPTS: $promptCnt" 192 } 193 set summary 194} 0 {CORRECT : PROMPT OK} 195 196Test help-1.6 {help tests} { 197 set result [HelpSend "help /tcl/math/expr" promptCnt] 198 set fh [open "$HELPDIR/tcl/math/expr"] 199 set expect [read $fh] 200 close $fh 201 set summary {} 202 if {"$expect" == "$result"} { 203 append summary "CORRECT" 204 } else { 205 append summary "DATA DOES NOT MATCH: $result" 206 } 207 if {$promptCnt >= 2} { 208 append summary " : PROMPT OK" 209 } else { 210 append summary " : NOT ENOUGH PROMPTS: $promptCnt" 211 } 212 set summary 213} 0 {CORRECT : PROMPT OK} 214 215Test help-1.7 {help tests} { 216 HelpSend "apropos upvar" promptCnt 217} 0 {tcl/variables/upvar - Create link to variable in a different stack frame 218} 219 220Test help-1.8 {help tests} { 221 HelpSend "apropos clock" promptCnt 222} 0 {tcl/time/clock - Obtain and manipulate time 223tcl/time/alarm - Set a process alarm clock. 224} 225 226Test help-1.9 {help tests} { 227 HelpSend "helpcd" promptCnt 228} 0 {} 229 230Test help-1.10 {help tests} { 231 HelpSend "helppwd" promptCnt 232} 0 {Current help subject: / 233} 234 235 236# Terminate the help server. 237 238puts $helpServerFH "exit 0" 239close $helpServerFH 240 241TestRemove HELP.PRG 242 243# cleanup 244::tcltest::cleanupTests 245return 246