# $Id: tcldoc_scanner.fcl,v 1.2 2004/11/05 17:36:48 tang Exp $ #//# # Handles scanning of file-level and procedure-level comments. # Identifies the various tags (<code>@author</code>, # <code>@return</code>, etc) and formats them suitably for the file's # annotation page. Also identifies one-line summary for the item and # adds it to the global summary table. This file is parsed by {@link # http://mini.net/tcl/fickle fickle} to create the actual scanner. # # @author Jason Tang (tang@jtang.org) # @version 1.0 #//# ###### # Begin autogenerated fickle (version 2.01) routines. # Although fickle itself is protected by the GNU Public License (GPL) # all user-supplied functions are protected by their respective # author's license. See http://mini.net/tcl/fickle for other details. ###### # If yywrap() returns false (zero), then it is assumed that the # function has gone ahead and set up yyin to point to another input # file, and scanning continues. If it returns true (non-zero), then # the scanner terminates, returning 0 to its caller. Note that in # either case, the start condition remains unchanged; it does not # revert to INITIAL. # -- from the flex(1) man page proc yywrap {} { return 1 } # ECHO copies yytext to the scanner's output if no arguments are # given. The scanner writes its ECHO output to the yyout global # (default, stdout), which may be redefined by the user simply by # assigning it to some other channel. # -- from the flex(1) man page proc ECHO {{s ""}} { if {$s == ""} { puts -nonewline $::yyout $::yytext } else { puts -nonewline $::yyout $s } } # YY_FLUSH_BUFFER flushes the scanner's internal buffer so that the # next time the scanner attempts to match a token, it will first # refill the buffer using YY_INPUT. # -- from the flex(1) man page proc YY_FLUSH_BUFFER {} { set ::yy_buffer "" set ::yy_index 0 set ::yy_done 0 } # yyrestart(new_file) may be called to point yyin at the new input # file. The switch-over to the new file is immediate (any previously # buffered-up input is lost). Note that calling yyrestart with yyin # as an argument thus throws away the current input buffer and # continues scanning the same input file. # -- from the flex(1) man page proc yyrestart {new_file} { set yyin $new_file YY_FLUSH_BUFFER } # The nature of how it gets its input can be controlled by defining # the YY_INPUT macro. YY_INPUT's calling sequence is # "YY_INPUT(buf,result,max_size)". Its action is to place up to # max_size characters in the character array buf and return in the # integer variable result either the number of characters read or the # constant YY_NULL (0 on Unix systems) to indicate EOF. The default # YY_INPUT reads from the global file-pointer "yyin". # -- from the flex(1) man page proc YY_INPUT {buf result max_size} { upvar $result ret_val upvar $buf new_data if {$::yyin != ""} { set new_data [read $::yyin $max_size] set ret_val [string length $new_data] } else { set new_data "" set ret_val 0 } } # yy_scan_string sets up input buffers for scanning in-memory # strings instead of files. Note that switching input sources does # not change the start condition. # -- from the flex(1) man page proc yy_scan_string {str} { append ::yy_buffer $str set ::yyin "" } # unput(c) puts the character c back onto the input stream. It will # be the next character scanned. The following action will take the # current token and cause it to be rescanned enclosed in parentheses. # -- from the flex(1) man page proc unput {c} { set s [string range $::yy_buffer 0 [expr {$::yy_index - 1}]] append s $c set ::yy_buffer [append s [string range $::yy_buffer $::yy_index end]] } # Returns all but the first n characters of the current token back to # the input stream, where they will be rescanned when the scanner # looks for the next match. yytext and yyleng are adjusted # appropriately. # -- from the flex(1) man page proc yyless {n} { set s [string range $::yy_buffer 0 [expr {$::yy_index - 1}]] append s [string range $::yytext $n end] set ::yy_buffer [append s [string range $::yy_buffer $::yy_index end]] set ::yytext [string range 0 [expr {$n - 1}]] set ::yyleng [string length $::yytext] } # input() reads the next character from the input stream. # -- from the flex(1) man page proc input {} { if {[string length $::yy_buffer] - $::yy_index < 1024} { set new_buffer_size 0 if {$::yy_done == 0} { YY_INPUT new_buffer new_buffer_size 1024 append ::yy_buffer $new_buffer if {$new_buffer_size == 0} { set ::yy_done 1 } } if $::yy_done { if {[yywrap] == 0} { return [input] } elseif {[string length $::yy_buffer] - $::yy_index == 0} { return {} } } } set c [string index $::yy_buffer $::yy_index] incr ::yy_index return $c } # Pushes the current start condition onto the top of the start # condition stack and switches to new_state as though you had used # BEGIN new_state. # -- from the flex(1) man page proc yy_push_state {new_state} { lappend ::yy_state_stack $new_state } # Pops off the top of the state stack; if the stack is now empty, then # pushes the state "INITIAL". # -- from the flex(1) man page proc yy_pop_state {} { set ::yy_state_stack [lrange $::yy_state_stack 0 end-1] if {$::yy_state_stack == ""} { yy_push_state INITIAL } } # Returns the top of the stack without altering the stack's contents. # -- from the flex(1) man page proc yy_top_state {} { return [lindex $::yy_state_stack end] } # BEGIN followed by the name of a start condition places the scanner # in the corresponding start condition. . . .Until the next BEGIN # action is executed, rules with the given start condition will be # active and rules with other start conditions will be inactive. If # the start condition is inclusive, then rules with no start # conditions at all will also be active. If it is exclusive, then # only rules qualified with the start condition will be active. # -- from the flex(1) man page proc BEGIN {new_state {prefix yy}} { eval set ::${prefix}_state_stack [lrange \$::${prefix}_state_stack 0 end-1] eval lappend ::${prefix}_state_stack $new_state } # initialize values used by the lexer set ::yy_buffer {} set ::yy_index 0 set ::yytext {} set ::yyleng 0 set ::yy_done 0 set ::yy_state_stack {} BEGIN INITIAL array set ::yy_state_table {SEE_L 0 SEE_A 0 LINK 0 INITIAL 1 SEE_S 0} if {![info exists ::yyin]} { set ::yyin "stdin" } if {![info exists ::yyout]} { set ::yyout "stdout" } ###### # autogenerated yylex function created by fickle ###### # Whenever yylex() is called, it scans tokens from the global input # file yyin (which defaults to stdin). It continues until it either # reaches an end-of-file (at which point it returns the value 0) or # one of its actions executes a return statement. # -- from the flex(1) man page proc yylex {} { upvar #0 ::yytext yytext upvar #0 ::yyleng yyleng while {1} { set yy_current_state [yy_top_state] if {[string length $::yy_buffer] - $::yy_index < 1024} { if {$::yy_done == 0} { set yynew_buffer "" YY_INPUT yynew_buffer yy_buffer_size 1024 append ::yy_buffer $yynew_buffer if {$yy_buffer_size == 0 && \ [string length $::yy_buffer] - $::yy_index == 0} { set ::yy_done 1 } } if $::yy_done { if {[yywrap] == 0} { set ::yy_done 0 continue } elseif {[string length $::yy_buffer] - $::yy_index == 0} { break } } } set ::yyleng 0 set yy_matched_rule -1 # rule 0: @author\s+ if {$::yy_state_table($yy_current_state) && \ [regexp -start $::yy_index -indices -line -- {\A(@author\s+)} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 0 } # rule 1: @deprecated\s+ if {$::yy_state_table($yy_current_state) && \ [regexp -start $::yy_index -indices -line -- {\A(@deprecated\s+)} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 1 } # rule 2: @param\s+\S+\s+ if {$::yy_state_table($yy_current_state) && \ [regexp -start $::yy_index -indices -line -- {\A(@param\s+\S+\s+)} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 2 } # rule 3: @return\s+ if {$::yy_state_table($yy_current_state) && \ [regexp -start $::yy_index -indices -line -- {\A(@return\s+)} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 3 } # rule 4: @see\s+\" if {$::yy_state_table($yy_current_state) && \ [regexp -start $::yy_index -indices -line -- {\A(@see\s+\")} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 4 } # rule 5: @see\s+\< if {$::yy_state_table($yy_current_state) && \ [regexp -start $::yy_index -indices -line -- {\A(@see\s+\<)} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 5 } # rule 6: @see\s+ if {$::yy_state_table($yy_current_state) && \ [regexp -start $::yy_index -indices -line -- {\A(@see\s+)} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 6 } # rule 7: @since\s+ if {$::yy_state_table($yy_current_state) && \ [regexp -start $::yy_index -indices -line -- {\A(@since\s+)} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 7 } # rule 8: @version\s+ if {$::yy_state_table($yy_current_state) && \ [regexp -start $::yy_index -indices -line -- {\A(@version\s+)} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 8 } # rule 9: <*>\{@docroot\} if {[regexp -start $::yy_index -indices -line -- {\A(\{@docroot\})} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 9 } # rule 10: <*>\{\s*@link\s+ if {[regexp -start $::yy_index -indices -line -- {\A(\{\s*@link\s+)} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 10 } # rule 11: <SEE_S>\" if {$yy_current_state == "SEE_S" && \ [regexp -start $::yy_index -indices -line -- {\A(\")} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 11 } # rule 12: <SEE_A></a> if {$yy_current_state == "SEE_A" && \ [regexp -start $::yy_index -indices -line -- {\A(</a>)} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 12 } # rule 13: <SEE_L>\S+(\s+\S+)? if {$yy_current_state == "SEE_L" && \ [regexp -start $::yy_index -indices -line -- {\A(\S+(\s+\S+)?)} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 13 } # rule 14: <LINK>[^\}]+\} if {$yy_current_state == "LINK" && \ [regexp -start $::yy_index -indices -line -- {\A([^\}]+\})} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 14 } # rule 15: [^@\{]* if {$::yy_state_table($yy_current_state) && \ [regexp -start $::yy_index -indices -line -- {\A([^@\{]*)} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 15 } # rule 16: <*>.|\n if {[regexp -start $::yy_index -indices -line -- {\A(.|\n)} $::yy_buffer yy_match] > 0 && \ [lindex $yy_match 1] - $::yy_index + 1 > $::yyleng} { set ::yytext [string range $::yy_buffer $::yy_index [lindex $yy_match 1]] set ::yyleng [string length $::yytext] set yy_matched_rule 16 } if {$yy_matched_rule == -1} { set ::yytext [string index $::yy_buffer $::yy_index] set ::yyleng 1 } incr ::yy_index $::yyleng # workaround for Tcl's circumflex behavior if {[string index $::yytext end] == "\n"} { set ::yy_buffer [string range $::yy_buffer $::yy_index end] set ::yy_index 0 } switch -- $yy_matched_rule { 0 { append ::annotrec(author) "\n<dd>"; set ::tag author } 1 { set ::annotrec(deprecated) ""; set ::tag deprecated } 2 { regexp -- {\A@param\s+(\S+)\s+} $yytext foo param_name append ::annotrec(param) "\n<dd><code>$param_name</code> - " set ::tag param } 3 { set ::annotrec(return) ""; set ::tag return } 4 { append ::annotrec(see) "<dd>""; set ::tag see; yy_push_state SEE_S } 5 { append ::annotrec(see) "<dd><"; set ::tag see; yy_push_state SEE_A } 6 { append ::annotrec(see) "<dd>"; set ::tag see; yy_push_state SEE_L } 7 { append ::annotrec(since) "\n<dd>"; set ::tag since } 8 { append ::annotrec(version) "\n<dd>"; set ::tag version } 9 { append ::annotrec($::tag) $::annotrec(docroot) } 10 { yy_push_state LINK } 11 { append ::annotrec(see) """; set ::tag text; yy_pop_state } 12 { append ::annotrec(see) "</a>"; set ::tag text; yy_pop_state } 13 { interp_link $yytext see; set ::tag text; yy_pop_state } 14 { interp_link [string range $yytext 0 end-1] link; yy_pop_state } 15 - 16 { append ::annotrec($::tag) $yytext } default { puts stderr "unmatched token: $::yytext in state `$yy_current_state'"; exit -1 } } } return 0 } ###### # end autogenerated fickle functions ###### # Flushes internal tables in preparation for writing a new annotation # file. This function must be called before using any other procedure # within this file. # # @param dest I/O channel to write annotations # @param basename name of source Tcl file being annotate # @param annothtmlname name of file to where annotations are being # written # @param docroot documents root directory proc new_annotation {dest basename annothtmlname docroot} { array unset ::annotfile set ::annotfile(dest) $dest set ::annotfile(basename) $basename set ::annotfile(annothtmlname) $annothtmlname set ::annotfile(docroot) $docroot array set ::annotfile {file_overview {} file_summary {} procs {}} } # Given the file-level comment (with <code>//#</code> markings # removed) scans it for tags. Generates the HTML code suitable for # writing to the file's annotation page. Adds a one-line summary for # the file to the global summary table. # # @param header a contiguous block of comments sans hash marks proc add_file_annotation {header} { YY_FLUSH_BUFFER yy_scan_string $header array unset ::annotrec set ::annotrec(text) "" set ::annotrec(docroot) $::annotfile(docroot) set ::annotrec(basename) $::annotfile(basename) set ::tag text yylex if {[yy_top_state] != "INITIAL"} { tcldoc_file_error "Tag not closed in file header" } set ::annotrec(text) [string trim $::annotrec(text)] set file_overview "<dl>\n" # calculate the file summary if [info exists ::annotrec(deprecated)] { set summary "<strong>Deprecated.</strong> <em>$::annotrec(deprecated)</em>\n" append file_overview "<dt><strong>Deprecated.</strong> <em>[string trim $::annotrec(deprecated)</em>]\n<dl>\n" } else { set summary [get_summary $::annotrec(text)] append file_overview "<dd>$::annotrec(text)\n<dl>\n" if [info exists ::annotrec(since)] { append file_overview "<dt><strong>Since:</strong><dd> [string trim $::annotrec(since)]\n" } if [info exists ::annotrec(version)] { append file_overview "<dt><strong>Version:</strong> [string trim $::annotrec(version)]\n" } } if [info exists ::annotrec(author)] { append file_overview "<dt><strong>Author:</strong> [string trim $::annotrec(author)]\n" } if [info exists ::annotrec(see)] { append file_overview "<dt><strong>See Also:</strong> [string trim $::annotrec(see)]\n" } append file_overview "</dl></dl>\n<hr>\n" set ::annotfile(file_overview) $file_overview set ::annotfile(file_summary) $summary } # Given a procedure-level comment scans it for tags. Generates the # HTML code suitable for writing to the file's annotation page. Adds # a one-line summary for the procedure to the global summary table. # # @param header a contiguous block of comments sans hash marks # @param procname name of the procedure being scanned # @param procargs a {@link #flatten_args flattened} list of arguments # to the procedure # @param procline line number for procedure declaration within its # source file proc add_proc_annotation {header procname procargs procline} { YY_FLUSH_BUFFER yy_scan_string $header array unset ::annotrec set ::annotrec(text) "" set ::annotrec(docroot) $::annotfile(docroot) set ::annotrec(basename) $::annotfile(basename) set ::tag text yylex if {[yy_top_state] != "INITIAL"} { tcldoc_file_error "Tag not closed in procedure header" } set ::annotrec(text) [string trim $::annotrec(text)] set proc_detail "<h3><a name=\"$procname\">$procname</a></h3> <pre>proc $procname \{ $procargs \}</pre> <dl>\n" # calculate the procedure summary if [info exists ::annotrec(deprecated)] { set summary "<strong>Deprecated.</strong> <em>[string trim $::annotrec(deprecated)]</em>\n" append proc_detail "<dt><strong>Deprecated.</strong> <em>[string trim $::annotrec(deprecated)]</em>\n" } else { set summary [get_summary $::annotrec(text)] append proc_detail "<dd>$::annotrec(text)<dl>\n" if [info exists ::annotrec(param)] { append proc_detail "<dt><strong>Parameters:</strong>\n[string trim $::annotrec(param)]\n" } if [info exists ::annotrec(return)] { append proc_detail "<dt><strong>Returns:</strong>\n<dd> [string trim $::annotrec(return)]\n" } if [info exists ::annotrec(since)] { append proc_detail "<dt><strong>Since:</strong>\n<dd> [string trim $::annotrec(since)]\n" } if [info exists ::annotrec(version)] { append proc_detail "<dt><strong>Version:</strong> [string trim $::annotrec(version)]\n" } } set proc_summary "<code><a href=\"#$procname\">$procname</a> \{ $procargs \}</code><br> $summary" if [info exists ::annotrec(author)] { append proc_detail "<dt><strong>Author:</strong>\n[strin trim $::annotrec(author)]\n" } if [info exists ::annotrec(see)] { append proc_detail "<dt><strong>See Also:</strong>\n[string trim $::annotrec(see)]\n" } set htmlname $::annotfile(basename).html set procid ${procname}_${procline} append proc_detail "<dt><strong>Defined in:</strong><dd><a href=\"$htmlname#$procid\">$::annotfile(basename), line $procline</a> </dl></dl>\n" # summary entries are: target, args, source, description, type add_summary $procname \ "$::annotfile(annothtmlname)#$procname" "\{ $procargs \}" \ "$::annotfile(basename)" $summary \ "proc" set ::annotfile($procname:s) $proc_summary set ::annotfile($procname:d) $proc_detail lappend ::annotfile(procs) $procname } # Helper function to the scanner that takes the arguments to a # <code>@link</code> or the third form of <code>@see</code> and splits # it into its component parts. For the name portion attempts to # resolve the procedure name as per the rules described in the {@link # tcldoc.html Tcldoc manual}. Checks if there is an optional label; # if not then set the label equal to the name. Finally adds the # results of the interpretation to the current tag being scanned. # # @param text tag text to scan # @param tag name of tag being scanned. proc interp_link {text tag} { # first extract the name and optional label if {[regexp -- {\A(\S+)\s*(.*)} $text foo name label] == 0} { tcldoc_file_error "Malformed @${tag} tag" } if {$label == ""} { set label [sanitize $name] } set text "<a href=\"" # try to split the name into a filename and procedure name set filename "" if {[string first "\#" $name] == -1} { set procname $name } else { foreach {filename procname} [split $name "\#"] {} } if {$filename == ""} { set filename $::annotrec(basename) } set procrecord [lookup_procrecord $procname $filename] if {$procrecord != {}} { foreach {procdest procline} $procrecord {} append text "${procdest}-annot.html\#$procname" } else { append text $name } append text "\">$label</a>" append ::annotrec($::tag) $text } # Actually writes the annotation file to disk at the location # specified in a previous call to {@link new_annotation}. If # <code>new_annotation</code> has not been called yet then behavior is # undetermined. # # @see new_annotation proc write_annotation {} { # write the file overview puts $::annotfile(dest) "$::annotfile(file_overview)" # write the procedure summary set procnames [lsort -dictionary $::annotfile(procs)] puts $::annotfile(dest) "<table border=\"1\" cellpadding=\"3\" cellspacing=\"0\" width=\"100%\"> <tr bgcolor=\"$::table_bg_color\"> <!-- -------------------- PROCEDURE SUMMARY -------------------- --> <td><font size=\"+2\"><strong><a name=\"proc_summary\">Procedure Summary</a></strong></font></td> </tr>" foreach procname $procnames { puts $::annotfile(dest) "<tr><td>$::annotfile($procname:s)</td></tr>" } puts $::annotfile(dest) "</table>\n<p>" # write actual procedure details puts $::annotfile(dest) "<!-- -------------------- PROCEDURE DETAIL -------------------- --> <table border=\"1\" cellpadding=\"3\" cellspacing=\"0\" width=\"100%\"> <tr bgcolor=\"$::table_bg_color\"> <td colspan=1><font size=\"+2\"><strong><a name=\"proc_detail\">Procedure Detail</a></strong></font></td> </tr> </table>" foreach procname [lrange $procnames 0 end-1] { puts $::annotfile(dest) "$::annotfile($procname:d)\n<hr>" } if [llength $procnames] { puts $::annotfile(dest) "$::annotfile([lindex $procnames end]:d)" } } # Determines the summary line given the file/procedure information. A # summary is the first sentence (text ending with a period and followed # by whitespace), excluding all HTML tags. # # @param text Text from a comment block (either file or procedure # level) from which to determine summary. # @return Calculated summary. proc get_summary {text} { regsub -all {<[^>]*>} $text {} text if {[regexp -- {\A([^\.]*.)(\s|\n)} $text foo summary] == 0} { set summary $text } return [string trim $summary] }