apidoc::tclcode_to_html (public)

 apidoc::tclcode_to_html [ -scope scope ] \
    [ -proc_namespace proc_namespace ] script

Defined in packages/acs-api-browser/tcl/acs-api-documentation-procs.tcl

Given a script, this proc formats it as HTML, including highlighting syntax in various colors and creating hyperlinks to other proc definitions. The inspiration for this proc was the tcl2html script created by Jeff Hobbs.

Switches:

-scope (optional)

-proc_namespace (optional)

Parameters:

script (required)

script to be formatted in HTML

Partial Call Graph (max 5 caller/called nodes):

Testcases:

acs_api_browser_apidoc_tclcode_to_html

Source code:

        set namespace_provided_p [expr {$proc_namespace ne ""}]

        set script [string trimright $script]
        template::head::add_style -style $::apidoc::style

        # Keywords will be colored as other procs, but not hyperlinked
        # to api-doc pages.  Perhaps we should hyperlink them to the Tcl man pages?
        # else and elseif are be treated as special cases later

        if {[namespace which ::xo::api] ne ""} {
            set XOTCL_KEYWORDS [list self my next]
            # Only command names are highlighted, otherwise we could add XOTcl method
            # names by [lsort -unique [concat [list self my next] ..
            # [::xotcl::Object info methods] [::xotcl::Class info methods] ]]
        } else {
            set XOTCL_KEYWORDS {}
        }

        set data [string map [list & "&amp;" < "&lt;" > "&gt;"] \n$script]
        set in_comment 0
        set in_quotes 0
        set proc_ok 1
        set l [string length $data]

        for {set i 0} {$i < $l} {incr i} {
            set char [string index $data $i]
            switch -- $char {

                "\\" {
                    append html [string range $data $i [incr i]]
                    # This might have been a backslash added to escape &, <, or >.
                    if {[regexp {^(amp;|lt;|gt;)} [string range $data $i end] match esc]} {
                        append html $esc
                        incr i [string length $esc]
                    }
                }

                "\$" {
                    if {$in_comment || [string index $data $i+1] eq " "} {
                        append html "\$"
                    } else {
                        set varl [length_var [string range $data $i end]]
                        append html [pretty_token var [string range $data $i $i+$varl]]
                        incr i $varl
                    }
                }

                "\"" {
                    if {$in_comment} {
                        append html \"
                    } elseif {$in_quotes} {
                        append html \" </span>
                        set in_quotes 0
                    } else {
                        append html "<span class='string'>" \"
                        set in_quotes 1
                        set proc_ok 0
                    }
                }

                "\#" {
                    set prevchar [string index $data $i-1]
                    if {$proc_ok && !$in_comment && [regexp {[\s;]} $prevchar]} {
                        set in_comment 1
                        set proc_ok 0
                        append html "<span class='comment'>"
                    }
                    append html "#"
                }

                "\n" {
                    set proc_ok 1
                    if {$in_quotes} {
                        set proc_ok 0
                    }
                    if {$in_comment} {
                        append html </span>
                    }
                    append html "\n"
                    set in_comment 0
                }

                ";" {
                    if {!$in_quotes && !$in_comment} {
                        set proc_ok 1
                    }
                    append html $char
                }

                "\{" {
                    if {!$in_quotes && !$in_comment} {
                        set proc_ok 1
                        set linestart [string last "\n" $data $i]
                        if {$linestart != -1} {
                            set segment [string range $data $linestart+1 $i]
                            #ns_log notice "SEGMENT <$segment>"
                            #
                            # When the line looks like from a
                            # definition of a proc/instproc/method,
                            # don't expect that the next word is a
                            # potential command, since this is rather
                            # an argument.
                            #
                            if {[regexp {(proc|method) } $segment]} {
                                set proc_ok 0
                            }
                        }
                    }
                    append html $char
                }

                "\}" {
                    append html "\}"
                    # Special case else and elseif
                    if {[regexp {^\}(\s*)(else|elseif)(\s*\{)} [string range $data $i end] match pre els post]} {

                        append html $pre [pretty_token keyword $els] $post
                        set proc_ok 1
                        incr i [expr {[string length $pre] + [string length $els] + [string length $post]}]
                    }
                }

                "\[" {
                    if {!$in_comment} {
                        set proc_ok 1
                    }
                    append html "\["
                }

                " " {
                    append html "&nbsp;"
                }

                "\t" {
                    append html "&nbsp;&nbsp;&nbsp;&nbsp;"
                }

                default {
                    if {$proc_ok} {
                        set proc_ok 0
                        set procl [length_proc [string range $data $i end]]
                        set proc_name [string range $data $i $i+$procl]

                        if {$proc_name eq "ad_proc"} {
                            #
                            # Pretty print comment after ad_proc rather than trying to index keywords
                            #
                            set endPos [string first \n $data $i+1]
                            if {$endPos > -1} {
                                set line0 [string range $data $i $endPos]
                                set line [string trim $line0]
                                #
                                # Does the line end with a open brace?
                                #
                                if {[string index $line end] eq "\{"} {
                                    # Do we have a signature of an
                                    # ad_proc (ad_proc ?-options ...?
                                    # name args) before that?
                                    #
                                    # Note that this handles just
                                    # single line ad-proc signatures,
                                    # not multi-line argument lists.

                                    set start [string range $line 0 end-1]
                                    set elements 3
                                    for {set idx 1} {[string index [lindex $start $idx] 0] eq "-"} {incr idx} {
                                        incr elements
                                    }

                                    if {[llength $start] == $elements} {
                                        #
                                        # Read next lines until brace is balanced.
                                        #
                                        set comment_start [expr {[string last "\{" $line] + $i}]
                                        set comment_end [expr {$comment_start + 1}]
                                        while {![info complete [string range $data $comment_start $comment_end]]
                                               && $comment_end < $l} {
                                            incr comment_end
                                        }
                                        if {$comment_end < $l} {
                                            #ns_log notice "AD_PROC CAND COMM [string range $data $comment_start $comment_end]"
                                            set url ""
                                            append html  "<a href='/api-doc/proc-view?proc=ad_proc' title='ad_proc'>"  [pretty_token proc ad_proc] </a>  [string range $data $i+7 $comment_start]  "<span class='comment'>"  [string range $data $comment_start+1 $comment_end-1]  "</span>\}"
                                            set i $comment_end
                                            continue
                                        }
                                    }
                                }
                            }
                            continue
                        }

                        #
                        # The last four words in the following clause
                        # are deprecated procs which are unfortunately
                        # picked up as commands by
                        # apidoc::tclcode_to_html. Therefore, we
                        # ignore these explicitly.
                        #
                        if {$proc_name in {* @ ? min max random content_type}} {
                            append html $proc_name

                        } elseif {$proc_name in $::apidoc::KEYWORDS ||
                                  ([regexp {^::(.*)} $proc_name match had_colons]
                                   && $had_colons in $::apidoc::KEYWORDS)} {

                            set url "/api-doc/proc-view?proc=[string trimleft $proc_name :]"
                            append html "<a href='[ns_quotehtml $url]' title='Tcl command'>"  [pretty_token keyword $proc_name] </a>

                            #append html [pretty_token keyword $proc_name]

                        } elseif {$proc_name in $XOTCL_KEYWORDS} {
                            append html [pretty_token keyword $proc_name]

                        } elseif {[string match "ns*" $proc_name]} {
                            set url "/api-doc/tcl-proc-view?tcl_proc=$proc_name"
                            append html "<a href='[ns_quotehtml $url]' title='[ns_info name] command'>"  [pretty_token proc $proc_name] </a>

                        } elseif {[string match "*__arg_parser" $proc_name]} {
                            append html [pretty_token helper $proc_name]

                        } elseif {$proc_namespace ne ""
                                  && [namespace which ::${proc_namespace}::${proc_name}] ne ""}  {

                            if {[is_object $scope ${proc_namespace}::${proc_name}]} {
                                set url [::xo::api object_url  -show_source 1 -show_methods 2  $scope ::${proc_namespace}::${proc_name}]
                                append html "<a href='[ns_quotehtml $url]' title='XOTcl object'>"  [pretty_token object $proc_name] </a>
                            } else {
                                set url [api_proc_url ${proc_namespace}::${proc_name}]
                                append html "<a href='[ns_quotehtml $url]' title='API command'>"  [pretty_token proc $proc_name] </a>
                            }
                        } elseif {[namespace which ::$proc_name] ne ""} {

                            set absolute_name [expr {[string match "::*" $proc_name]
                                                     ? $proc_name : "::${proc_name}" }]

                            if {[is_object $scope $absolute_name]} {
                                set url [::xo::api object_url  -show_source 1 -show_methods 2  $scope $absolute_name]
                                append html "<a href='[ns_quotehtml $url]' title='XOTcl object'>"  [pretty_token object $proc_name] </a>
                            } else {
                                set url [api_proc_url $proc_name]
                                append html "<a href='[ns_quotehtml $url]' title='API command'>"  [pretty_token proc $proc_name] </a>
                            }
                        } else {
                            #if {$procl > 2 && [string match ad_* $proc_name]} {
                            #    ns_log notice "TCLCODE: giving up on '$proc_name' ($procl) [string range $data $i $i+20]"
                            #}
                            append html $proc_name
                            #set proc_ok 1
                        }
                        incr i $procl

                        if {$proc_name eq "namespace" && !$namespace_provided_p} {
                            set endPos [string first \n $data $i+1]
                            if {$endPos > -1} {
                                set line [string range $data $i+1 $endPos]
                                regexp {\s*eval\s+(::)?(\S+)\s+} $line . . proc_namespace
                            }
                        }

                        if {$proc_name eq "regexp" || $proc_name eq "regsub"} {
                            #
                            # Hack for nasty regexp stuff
                            #
                            set regexpl [length_regexp [string range $data $i end]]
                            append html [string range $data $i+1 $i+$regexpl]
                            incr i $regexpl
                        } elseif {$proc_name in {util_memoize util_memoize_seed}} {
                            #
                            # special cases for util_memoize
                            #
                            set reminder [string range $data $i+1 end]

                            if {[regexp {^(\s*\[\s*list)} $reminder _ list]} {
                                # util_memoize + list
                                append html " \[" [pretty_token keyword list]
                                incr i [string length $list]
                                set proc_ok 1
                            } else {
                                # util_memoize without list
                                set proc_ok 1
                            }
                        }
                    } else {
                        append html $char
                        set proc_ok 0
                    }
                }
            }
        }

        # We added a linefeed at the beginning to simplify processing
        return [string range $html 1 end]

XQL Not present:

Generic, PostgreSQL, Oracle