1# $Id: tcldoc_scanner.tcl,v 1.1 2012/01/05 22:36:52 mused Exp $ 2 3#//# 4# Handles scanning of file-level and procedure-level comments. 5# Identifies the various tags (<code>@author</code>, 6# <code>@return</code>, etc) and formats them suitably for the file's 7# annotation page. Also identifies one-line summary for the item and 8# adds it to the global summary table. This file is parsed by {@link 9# http://mini.net/tcl/fickle fickle} to create the actual scanner. 10# 11# @author Jason Tang (tang@jtang.org) 12# @version 1.0 13#//# 14 15###### 16# Begin autogenerated fickle (version 2.01) routines. 17# Although fickle itself is protected by the GNU Public License (GPL) 18# all user-supplied functions are protected by their respective 19# author's license. See http://mini.net/tcl/fickle for other details. 20###### 21 22# If yywrap() returns false (zero), then it is assumed that the 23# function has gone ahead and set up yyin to point to another input 24# file, and scanning continues. If it returns true (non-zero), then 25# the scanner terminates, returning 0 to its caller. Note that in 26# either case, the start condition remains unchanged; it does not 27# revert to INITIAL. 28# -- from the flex(1) man page 29proc yywrap {} { 30 return 1 31} 32 33# ECHO copies yytext to the scanner's output if no arguments are 34# given. The scanner writes its ECHO output to the yyout global 35# (default, stdout), which may be redefined by the user simply by 36# assigning it to some other channel. 37# -- from the flex(1) man page 38proc ECHO {{s ""}} { 39 if {$s == ""} { 40 puts -nonewline $::yyout $::yytext 41 } else { 42 puts -nonewline $::yyout $s 43 } 44} 45 46# YY_FLUSH_BUFFER flushes the scanner's internal buffer so that the 47# next time the scanner attempts to match a token, it will first 48# refill the buffer using YY_INPUT. 49# -- from the flex(1) man page 50proc YY_FLUSH_BUFFER {} { 51 set ::yy_buffer "" 52 set ::yy_index 0 53 set ::yy_done 0 54} 55 56# yyrestart(new_file) may be called to point yyin at the new input 57# file. The switch-over to the new file is immediate (any previously 58# buffered-up input is lost). Note that calling yyrestart with yyin 59# as an argument thus throws away the current input buffer and 60# continues scanning the same input file. 61# -- from the flex(1) man page 62proc yyrestart {new_file} { 63 set yyin $new_file 64 YY_FLUSH_BUFFER 65} 66 67# The nature of how it gets its input can be controlled by defining 68# the YY_INPUT macro. YY_INPUT's calling sequence is 69# "YY_INPUT(buf,result,max_size)". Its action is to place up to 70# max_size characters in the character array buf and return in the 71# integer variable result either the number of characters read or the 72# constant YY_NULL (0 on Unix systems) to indicate EOF. The default 73# YY_INPUT reads from the global file-pointer "yyin". 74# -- from the flex(1) man page 75proc YY_INPUT {buf result max_size} { 76 upvar $result ret_val 77 upvar $buf new_data 78 if {$::yyin != ""} { 79 set new_data [read $::yyin $max_size] 80 set ret_val [string length $new_data] 81 } else { 82 set new_data "" 83 set ret_val 0 84 } 85} 86 87# yy_scan_string sets up input buffers for scanning in-memory 88# strings instead of files. Note that switching input sources does 89# not change the start condition. 90# -- from the flex(1) man page 91proc yy_scan_string {str} { 92 append ::yy_buffer $str 93 set ::yyin "" 94} 95 96# unput(c) puts the character c back onto the input stream. It will 97# be the next character scanned. The following action will take the 98# current token and cause it to be rescanned enclosed in parentheses. 99# -- from the flex(1) man page 100proc unput {c} { 101 set s [string range $::yy_buffer 0 [expr {$::yy_index - 1}]] 102 append s $c 103 set ::yy_buffer [append s [string range $::yy_buffer $::yy_index end]] 104} 105 106# Returns all but the first n characters of the current token back to 107# the input stream, where they will be rescanned when the scanner 108# looks for the next match. yytext and yyleng are adjusted 109# appropriately. 110# -- from the flex(1) man page 111proc yyless {n} { 112 set s [string range $::yy_buffer 0 [expr {$::yy_index - 1}]] 113 append s [string range $::yytext $n end] 114 set ::yy_buffer [append s [string range $::yy_buffer $::yy_index end]] 115 set ::yytext [string range 0 [expr {$n - 1}]] 116 set ::yyleng [string length $::yytext] 117} 118 119# input() reads the next character from the input stream. 120# -- from the flex(1) man page 121proc input {} { 122 if {[string length $::yy_buffer] - $::yy_index < 1024} { 123 set new_buffer_size 0 124 if {$::yy_done == 0} { 125 YY_INPUT new_buffer new_buffer_size 1024 126 append ::yy_buffer $new_buffer 127 if {$new_buffer_size == 0} { 128 set ::yy_done 1 129 } 130 } 131 if $::yy_done { 132 if {[yywrap] == 0} { 133 return [input] 134 } elseif {[string length $::yy_buffer] - $::yy_index == 0} { 135 return {} 136 } 137 } 138 } 139 set c [string index $::yy_buffer $::yy_index] 140 incr ::yy_index 141 return $c 142} 143 144# Pushes the current start condition onto the top of the start 145# condition stack and switches to new_state as though you had used 146# BEGIN new_state. 147# -- from the flex(1) man page 148proc yy_push_state {new_state} { 149 lappend ::yy_state_stack $new_state 150} 151 152# Pops off the top of the state stack; if the stack is now empty, then 153# pushes the state "INITIAL". 154# -- from the flex(1) man page 155proc yy_pop_state {} { 156 set ::yy_state_stack [lrange $::yy_state_stack 0 end-1] 157 if {$::yy_state_stack == ""} { 158 yy_push_state INITIAL 159 } 160} 161 162# Returns the top of the stack without altering the stack's contents. 163# -- from the flex(1) man page 164proc yy_top_state {} { 165 return [lindex $::yy_state_stack end] 166} 167 168# BEGIN followed by the name of a start condition places the scanner 169# in the corresponding start condition. . . .Until the next BEGIN 170# action is executed, rules with the given start condition will be 171# active and rules with other start conditions will be inactive. If 172# the start condition is inclusive, then rules with no start 173# conditions at all will also be active. If it is exclusive, then 174# only rules qualified with the start condition will be active. 175# -- from the flex(1) man page 176proc BEGIN {new_state {prefix yy}} { 177 eval set ::${prefix}_state_stack [lrange \$::${prefix}_state_stack 0 end-1] 178 eval lappend ::${prefix}_state_stack $new_state 179} 180 181# initialize values used by the lexer 182set ::yy_buffer {} 183set ::yy_index 0 184set ::yytext {} 185set ::yyleng 0 186set ::yy_done 0 187set ::yy_state_stack {} 188BEGIN INITIAL 189array set ::yy_state_table {SEE_L 0 SEE_A 0 LINK 0 INITIAL 1 SEE_S 0} 190if {![info exists ::yyin]} { 191 set ::yyin "stdin" 192} 193if {![info exists ::yyout]} { 194 set ::yyout "stdout" 195} 196 197###### 198# autogenerated yylex function created by fickle 199###### 200 201# Whenever yylex() is called, it scans tokens from the global input 202# file yyin (which defaults to stdin). It continues until it either 203# reaches an end-of-file (at which point it returns the value 0) or 204# one of its actions executes a return statement. 205# -- from the flex(1) man page 206proc yylex {} { 207 upvar #0 ::yytext yytext 208 upvar #0 ::yyleng yyleng 209 while {1} { 210 set yy_current_state [yy_top_state] 211 if {[string length $::yy_buffer] - $::yy_index < 1024} { 212 if {$::yy_done == 0} { 213 set yynew_buffer "" 214 YY_INPUT yynew_buffer yy_buffer_size 1024 215 append ::yy_buffer $yynew_buffer 216 if {$yy_buffer_size == 0 && \ 217 [string length $::yy_buffer] - $::yy_index == 0} { 218 set ::yy_done 1 219 } 220 } 221 if $::yy_done { 222 if {[yywrap] == 0} { 223 set ::yy_done 0 224 continue 225 } elseif {[string length $::yy_buffer] - $::yy_index == 0} { 226 break 227 } 228 } 229 } 230 set ::yyleng 0 231 set yy_matched_rule -1 232 # rule 0: @author\s+ 233 if {$::yy_state_table($yy_current_state) && \ 234 [regexp -start $::yy_index -indices -line -- {\A(@author\s+)} $::yy_buffer yy_match] > 0 && \ 235 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 236 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 237 set ::yyleng [string length $::yytext] 238 set yy_matched_rule 0 239 } 240 # rule 1: @deprecated\s+ 241 if {$::yy_state_table($yy_current_state) && \ 242 [regexp -start $::yy_index -indices -line -- {\A(@deprecated\s+)} $::yy_buffer yy_match] > 0 && \ 243 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 244 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 245 set ::yyleng [string length $::yytext] 246 set yy_matched_rule 1 247 } 248 # rule 2: @param\s+\S+\s+ 249 if {$::yy_state_table($yy_current_state) && \ 250 [regexp -start $::yy_index -indices -line -- {\A(@param\s+\S+\s+)} $::yy_buffer yy_match] > 0 && \ 251 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 252 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 253 set ::yyleng [string length $::yytext] 254 set yy_matched_rule 2 255 } 256 # rule 3: @return\s+ 257 if {$::yy_state_table($yy_current_state) && \ 258 [regexp -start $::yy_index -indices -line -- {\A(@return\s+)} $::yy_buffer yy_match] > 0 && \ 259 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 260 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 261 set ::yyleng [string length $::yytext] 262 set yy_matched_rule 3 263 } 264 # rule 4: @see\s+\" 265 if {$::yy_state_table($yy_current_state) && \ 266 [regexp -start $::yy_index -indices -line -- {\A(@see\s+\")} $::yy_buffer yy_match] > 0 && \ 267 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 268 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 269 set ::yyleng [string length $::yytext] 270 set yy_matched_rule 4 271 } 272 # rule 5: @see\s+\< 273 if {$::yy_state_table($yy_current_state) && \ 274 [regexp -start $::yy_index -indices -line -- {\A(@see\s+\<)} $::yy_buffer yy_match] > 0 && \ 275 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 276 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 277 set ::yyleng [string length $::yytext] 278 set yy_matched_rule 5 279 } 280 # rule 6: @see\s+ 281 if {$::yy_state_table($yy_current_state) && \ 282 [regexp -start $::yy_index -indices -line -- {\A(@see\s+)} $::yy_buffer yy_match] > 0 && \ 283 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 284 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 285 set ::yyleng [string length $::yytext] 286 set yy_matched_rule 6 287 } 288 # rule 7: @since\s+ 289 if {$::yy_state_table($yy_current_state) && \ 290 [regexp -start $::yy_index -indices -line -- {\A(@since\s+)} $::yy_buffer yy_match] > 0 && \ 291 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 292 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 293 set ::yyleng [string length $::yytext] 294 set yy_matched_rule 7 295 } 296 # rule 8: @version\s+ 297 if {$::yy_state_table($yy_current_state) && \ 298 [regexp -start $::yy_index -indices -line -- {\A(@version\s+)} $::yy_buffer yy_match] > 0 && \ 299 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 300 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 301 set ::yyleng [string length $::yytext] 302 set yy_matched_rule 8 303 } 304 # rule 9: <*>\{@docroot\} 305 if {[regexp -start $::yy_index -indices -line -- {\A(\{@docroot\})} $::yy_buffer yy_match] > 0 && \ 306 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 307 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 308 set ::yyleng [string length $::yytext] 309 set yy_matched_rule 9 310 } 311 # rule 10: <*>\{\s*@link\s+ 312 if {[regexp -start $::yy_index -indices -line -- {\A(\{\s*@link\s+)} $::yy_buffer yy_match] > 0 && \ 313 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 314 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 315 set ::yyleng [string length $::yytext] 316 set yy_matched_rule 10 317 } 318 # rule 11: <SEE_S>\" 319 if {$yy_current_state == "SEE_S" && \ 320 [regexp -start $::yy_index -indices -line -- {\A(\")} $::yy_buffer yy_match] > 0 && \ 321 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 322 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 323 set ::yyleng [string length $::yytext] 324 set yy_matched_rule 11 325 } 326 # rule 12: <SEE_A></a> 327 if {$yy_current_state == "SEE_A" && \ 328 [regexp -start $::yy_index -indices -line -- {\A(</a>)} $::yy_buffer yy_match] > 0 && \ 329 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 330 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 331 set ::yyleng [string length $::yytext] 332 set yy_matched_rule 12 333 } 334 # rule 13: <SEE_L>\S+(\s+\S+)? 335 if {$yy_current_state == "SEE_L" && \ 336 [regexp -start $::yy_index -indices -line -- {\A(\S+(\s+\S+)?)} $::yy_buffer yy_match] > 0 && \ 337 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 338 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 339 set ::yyleng [string length $::yytext] 340 set yy_matched_rule 13 341 } 342 # rule 14: <LINK>[^\}]+\} 343 if {$yy_current_state == "LINK" && \ 344 [regexp -start $::yy_index -indices -line -- {\A([^\}]+\})} $::yy_buffer yy_match] > 0 && \ 345 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 346 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 347 set ::yyleng [string length $::yytext] 348 set yy_matched_rule 14 349 } 350 # rule 15: [^@\{]* 351 if {$::yy_state_table($yy_current_state) && \ 352 [regexp -start $::yy_index -indices -line -- {\A([^@\{]*)} $::yy_buffer yy_match] > 0 && \ 353 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 354 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 355 set ::yyleng [string length $::yytext] 356 set yy_matched_rule 15 357 } 358 # rule 16: <*>.|\n 359 if {[regexp -start $::yy_index -indices -line -- {\A(.|\n)} $::yy_buffer yy_match] > 0 && \ 360 [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { 361 set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] 362 set ::yyleng [string length $::yytext] 363 set yy_matched_rule 16 364 } 365 if {$yy_matched_rule == -1} { 366 set ::yytext [string index $::yy_buffer $::yy_index] 367 set ::yyleng 1 368 } 369 incr ::yy_index $::yyleng 370 # workaround for Tcl's circumflex behavior 371 if {[string index $::yytext end] == "\n"} { 372 set ::yy_buffer [string range $::yy_buffer $::yy_index end] 373 set ::yy_index 0 374 } 375 switch -- $yy_matched_rule { 376 0 { 377append ::annotrec(author) "\n<dd>"; set ::tag author 378 } 379 1 { 380set ::annotrec(deprecated) ""; set ::tag deprecated 381 } 382 2 { 383regexp -- {\A@param\s+(\S+)\s+} $yytext foo param_name 384 append ::annotrec(param) "\n<dd><code>$param_name</code> - " 385 set ::tag param 386 } 387 3 { 388set ::annotrec(return) ""; set ::tag return 389 } 390 4 { 391append ::annotrec(see) "<dd>""; set ::tag see; yy_push_state SEE_S 392 } 393 5 { 394append ::annotrec(see) "<dd><"; set ::tag see; yy_push_state SEE_A 395 } 396 6 { 397append ::annotrec(see) "<dd>"; set ::tag see; yy_push_state SEE_L 398 } 399 7 { 400append ::annotrec(since) "\n<dd>"; set ::tag since 401 } 402 8 { 403append ::annotrec(version) "\n<dd>"; set ::tag version 404 } 405 9 { 406append ::annotrec($::tag) $::annotrec(docroot) 407 } 408 10 { 409yy_push_state LINK 410 } 411 11 { 412append ::annotrec(see) """; set ::tag text; yy_pop_state 413 } 414 12 { 415append ::annotrec(see) "</a>"; set ::tag text; yy_pop_state 416 } 417 13 { 418interp_link $yytext see; set ::tag text; yy_pop_state 419 } 420 14 { 421interp_link [string range $yytext 0 end-1] link; yy_pop_state 422 } 423 15 - 424 16 { 425append ::annotrec($::tag) $yytext 426 } 427 default 428 { puts stderr "unmatched token: $::yytext in state `$yy_current_state'"; exit -1 } 429 } 430 } 431 return 0 432} 433###### 434# end autogenerated fickle functions 435###### 436 437 438# Flushes internal tables in preparation for writing a new annotation 439# file. This function must be called before using any other procedure 440# within this file. 441# 442# @param dest I/O channel to write annotations 443# @param basename name of source Tcl file being annotate 444# @param annothtmlname name of file to where annotations are being 445# written 446# @param docroot documents root directory 447proc new_annotation {dest basename annothtmlname docroot} { 448 array unset ::annotfile 449 set ::annotfile(dest) $dest 450 set ::annotfile(basename) $basename 451 set ::annotfile(annothtmlname) $annothtmlname 452 set ::annotfile(docroot) $docroot 453 array set ::annotfile {file_overview {} file_summary {} procs {}} 454} 455 456# Given the file-level comment (with <code>//#</code> markings 457# removed) scans it for tags. Generates the HTML code suitable for 458# writing to the file's annotation page. Adds a one-line summary for 459# the file to the global summary table. 460# 461# @param header a contiguous block of comments sans hash marks 462proc add_file_annotation {header} { 463 YY_FLUSH_BUFFER 464 yy_scan_string $header 465 array unset ::annotrec 466 set ::annotrec(text) "" 467 set ::annotrec(docroot) $::annotfile(docroot) 468 set ::annotrec(basename) $::annotfile(basename) 469 set ::tag text 470 yylex 471 if {[yy_top_state] != "INITIAL"} { 472 tcldoc_file_error "Tag not closed in file header" 473 } 474 475 set ::annotrec(text) [string trim $::annotrec(text)] 476 set file_overview "<dl>\n" 477 478 # calculate the file summary 479 if [info exists ::annotrec(deprecated)] { 480 set summary "<strong>Deprecated.</strong> <em>$::annotrec(deprecated)</em>\n" 481 append file_overview "<dt><strong>Deprecated.</strong> <em>[string trim $::annotrec(deprecated)</em>]\n<dl>\n" 482 } else { 483 set summary [get_summary $::annotrec(text)] 484 append file_overview "<dd>$::annotrec(text)\n<dl>\n" 485 if [info exists ::annotrec(since)] { 486 append file_overview "<dt><strong>Since:</strong><dd> [string trim $::annotrec(since)]\n" 487 } 488 if [info exists ::annotrec(version)] { 489 append file_overview "<dt><strong>Version:</strong> [string trim $::annotrec(version)]\n" 490 } 491 } 492 if [info exists ::annotrec(author)] { 493 append file_overview "<dt><strong>Author:</strong> [string trim $::annotrec(author)]\n" 494 } 495 if [info exists ::annotrec(see)] { 496 append file_overview "<dt><strong>See Also:</strong> [string trim $::annotrec(see)]\n" 497 } 498 499 append file_overview "</dl></dl>\n<hr>\n" 500 501 set ::annotfile(file_overview) $file_overview 502 set ::annotfile(file_summary) $summary 503} 504 505# Given a procedure-level comment scans it for tags. Generates the 506# HTML code suitable for writing to the file's annotation page. Adds 507# a one-line summary for the procedure to the global summary table. 508# 509# @param header a contiguous block of comments sans hash marks 510# @param procname name of the procedure being scanned 511# @param procargs a {@link #flatten_args flattened} list of arguments 512# to the procedure 513# @param procline line number for procedure declaration within its 514# source file 515proc add_proc_annotation {header procname procargs procline} { 516 YY_FLUSH_BUFFER 517 yy_scan_string $header 518 array unset ::annotrec 519 set ::annotrec(text) "" 520 set ::annotrec(docroot) $::annotfile(docroot) 521 set ::annotrec(basename) $::annotfile(basename) 522 set ::tag text 523 yylex 524 if {[yy_top_state] != "INITIAL"} { 525 tcldoc_file_error "Tag not closed in procedure header" 526 } 527 528 set ::annotrec(text) [string trim $::annotrec(text)] 529 set proc_detail "<h3><a name=\"$procname\">$procname</a></h3> 530<pre>proc $procname \{ $procargs \}</pre> 531<dl>\n" 532 533 # calculate the procedure summary 534 if [info exists ::annotrec(deprecated)] { 535 set summary "<strong>Deprecated.</strong> <em>[string trim $::annotrec(deprecated)]</em>\n" 536 append proc_detail "<dt><strong>Deprecated.</strong> <em>[string trim $::annotrec(deprecated)]</em>\n" 537 } else { 538 set summary [get_summary $::annotrec(text)] 539 append proc_detail "<dd>$::annotrec(text)<dl>\n" 540 if [info exists ::annotrec(param)] { 541 append proc_detail "<dt><strong>Parameters:</strong>\n[string trim $::annotrec(param)]\n" 542 } 543 if [info exists ::annotrec(return)] { 544 append proc_detail "<dt><strong>Returns:</strong>\n<dd> [string trim $::annotrec(return)]\n" 545 } 546 if [info exists ::annotrec(since)] { 547 append proc_detail "<dt><strong>Since:</strong>\n<dd> [string trim $::annotrec(since)]\n" 548 } 549 if [info exists ::annotrec(version)] { 550 append proc_detail "<dt><strong>Version:</strong> [string trim $::annotrec(version)]\n" 551 } 552 } 553 554 set proc_summary "<code><a href=\"#$procname\">$procname</a> \{ $procargs \}</code><br> 555 $summary" 556 557 if [info exists ::annotrec(author)] { 558 append proc_detail "<dt><strong>Author:</strong>\n[strin trim $::annotrec(author)]\n" 559 } 560 if [info exists ::annotrec(see)] { 561 append proc_detail "<dt><strong>See Also:</strong>\n[string trim $::annotrec(see)]\n" 562 } 563 564 set htmlname $::annotfile(basename).html 565 set procid ${procname}_${procline} 566 append proc_detail "<dt><strong>Defined in:</strong><dd><a href=\"$htmlname#$procid\">$::annotfile(basename), line $procline</a> 567</dl></dl>\n" 568 569 # summary entries are: target, args, source, description, type 570 add_summary $procname \ 571 "$::annotfile(annothtmlname)#$procname" "\{ $procargs \}" \ 572 "$::annotfile(basename)" $summary \ 573 "proc" 574 set ::annotfile($procname:s) $proc_summary 575 set ::annotfile($procname:d) $proc_detail 576 lappend ::annotfile(procs) $procname 577} 578 579# Helper function to the scanner that takes the arguments to a 580# <code>@link</code> or the third form of <code>@see</code> and splits 581# it into its component parts. For the name portion attempts to 582# resolve the procedure name as per the rules described in the {@link 583# tcldoc.html Tcldoc manual}. Checks if there is an optional label; 584# if not then set the label equal to the name. Finally adds the 585# results of the interpretation to the current tag being scanned. 586# 587# @param text tag text to scan 588# @param tag name of tag being scanned. 589proc interp_link {text tag} { 590 # first extract the name and optional label 591 if {[regexp -- {\A(\S+)\s*(.*)} $text foo name label] == 0} { 592 tcldoc_file_error "Malformed @${tag} tag" 593 } 594 if {$label == ""} { 595 set label [sanitize $name] 596 } 597 set text "<a href=\"" 598 # try to split the name into a filename and procedure name 599 set filename "" 600 if {[string first "\#" $name] == -1} { 601 set procname $name 602 } else { 603 foreach {filename procname} [split $name "\#"] {} 604 } 605 if {$filename == ""} { 606 set filename $::annotrec(basename) 607 } 608 set procrecord [lookup_procrecord $procname $filename] 609 if {$procrecord != {}} { 610 foreach {procdest procline} $procrecord {} 611 append text "${procdest}-annot.html\#$procname" 612 } else { 613 append text $name 614 } 615 append text "\">$label</a>" 616 append ::annotrec($::tag) $text 617} 618 619# Actually writes the annotation file to disk at the location 620# specified in a previous call to {@link new_annotation}. If 621# <code>new_annotation</code> has not been called yet then behavior is 622# undetermined. 623# 624# @see new_annotation 625proc write_annotation {} { 626 # write the file overview 627 puts $::annotfile(dest) "$::annotfile(file_overview)" 628 629 # write the procedure summary 630 set procnames [lsort -dictionary $::annotfile(procs)] 631 puts $::annotfile(dest) "<table border=\"1\" cellpadding=\"3\" cellspacing=\"0\" width=\"100%\"> 632<tr bgcolor=\"$::table_bg_color\"> 633<!-- -------------------- PROCEDURE SUMMARY -------------------- --> 634<td><font size=\"+2\"><strong><a name=\"proc_summary\">Procedure Summary</a></strong></font></td> 635</tr>" 636 foreach procname $procnames { 637 puts $::annotfile(dest) "<tr><td>$::annotfile($procname:s)</td></tr>" 638 } 639 puts $::annotfile(dest) "</table>\n<p>" 640 641 # write actual procedure details 642 puts $::annotfile(dest) "<!-- -------------------- PROCEDURE DETAIL -------------------- --> 643<table border=\"1\" cellpadding=\"3\" cellspacing=\"0\" width=\"100%\"> 644<tr bgcolor=\"$::table_bg_color\"> 645<td colspan=1><font size=\"+2\"><strong><a name=\"proc_detail\">Procedure Detail</a></strong></font></td> 646</tr> 647</table>" 648 foreach procname [lrange $procnames 0 end-1] { 649 puts $::annotfile(dest) "$::annotfile($procname:d)\n<hr>" 650 } 651 if [llength $procnames] { 652 puts $::annotfile(dest) "$::annotfile([lindex $procnames end]:d)" 653 } 654} 655 656 657# Determines the summary line given the file/procedure information. A 658# summary is the first sentence (text ending with a period and followed 659# by whitespace), excluding all HTML tags. 660# 661# @param text Text from a comment block (either file or procedure 662# level) from which to determine summary. 663# @return Calculated summary. 664proc get_summary {text} { 665 regsub -all {<[^>]*>} $text {} text 666 if {[regexp -- {\A([^\.]*.)(\s|\n)} $text foo summary] == 0} { 667 set summary $text 668 } 669 return [string trim $summary] 670} 671