ad_library {
Routines for generating API documentation.
@author Jon Salz (jsalz@mit.edu)
@author Lars Pind (lars@arsdigita.com)
@creation-date 21 Jun 2000
@cvs-id $Id: acs-api-documentation-procs.tcl,v 1.72.2.16 2019/09/29 16:07:19 gustafn Exp $
}
namespace eval ::apidoc {
if {[ns_info name] eq "NaviServer"} {
#
# NaviServer at sourceforge
#
set ns_api_host "https://naviserver.sourceforge.io/"
set ns_api_index [list "n/naviserver/files/" "n/"]
set ns_api_root [list \
${ns_api_host}[lindex $ns_api_index 0] \
${ns_api_host}[lindex $ns_api_index 1] ]
set ns_api_html_index [list \
[lindex $ns_api_root 0]commandlist.html \
[lindex $ns_api_root 1]toc.html ]
} else {
#
# AOLserver wiki on panpotic
#
set ns_api_host "http://panoptic.com/"
set ns_api_index "wiki/aolserver/Tcl_API"
set ns_api_root ${ns_api_host}${ns_api_index}
set ns_api_html_index $ns_api_root
}
set tcl_api_html_index "https://www.tcl-lang.org/man/tcl$::tcl_version/TclCmd/contents.htm"
# set style {
# .code .comment {color: #006600; font-weight: normal; font-style: italic;}
# .code .keyword {color: #0000AA; font-weight: bold; font-style: normal;}
# .code .string {color: #990000; font-weight: normal; font-style: italic;}
# .code .var {color: #660066; font-weight: normal; font-style: normal;}
# .code .proc {color: #0000CC; font-weight: normal; font-style: normal;}
# .code .object {color: #000066; font-weight: bold; font-style: normal;}
# .code .helper {color: #0000CC; font-weight: bold; font-style: normal;}
# pre.code a {text-decoration: none;}
# }
set style {
.code .comment {color: #717ab3; font-weight: normal; font-style: italic;}
.code .keyword {color: #7f0055; font-weight: normal; font-style: normal;}
.code .string {color: #779977; font-weight: normal; font-style: italic;}
.code .var {color: #AF663F; font-weight: normal; font-style: normal;}
.code .proc {color: #0000CC; font-weight: normal; font-style: normal;}
.code .object {color: #000066; font-weight: bold; font-style: normal;}
.code .helper {color: #aaaacc; font-weight: bold; font-style: normal;}
pre.code {
background: #fefefa;
border-color: #aaaaaa;
border-style: solid;
border-width: 1px;
/*width: 900px; overflow: auto;*/
}
pre.code a {text-decoration: none;}
pre.code code { white-space:pre-wrap; }
}
set KEYWORDS {
after append apply array bgerror binary break catch cd chan
clock close concat continue coroutine default dict encoding eof error
eval exec expr fblocked fconfigure fcopy file fileevent flush
for foreach format gets glob global if incr info interp join
lappend lassign lindex linsert list llength lmap load lrange
lrepeat lreplace lreverse lsearch lset lsort namespace open package
pid proc puts pwd read refchan regexp regsub rename return
scan seek set socket source split string subst switch tailcall tell
throw time tm trace transchan try unload unset update uplevel upvar variable vwait
while yield yieldto zlib
}
}
ad_proc -public api_read_script_documentation {
path
} {
Reads the contract from a Tcl content page.
@param path the path of the Tcl file to examine, relative to the
OpenACS root directory.
@return a list representation of the documentation element array, or
an empty list if the file does not contain a doc_page_contract
block.
@error if the file does not exist.
} {
# First, examine the file to determine whether the first non-comment
# line begins with the string "ad_page_contract".
set has_contract_p 0
if { ![file exists "$::acs::rootdir/$path"] } {
error "File $path does not exist"
}
set file [open "$::acs::rootdir/$path" "r"]
while { [gets $file line] >= 0 } {
# Eliminate any comment characters.
regsub -all {\#.*$} $line "" line
set line [string trim $line]
if { $line ne "" } {
set has_contract_p [regexp {(^ad_(page|include)_contract\s)|(Package initialize )} $line]
break
}
}
close $file
if { !$has_contract_p } {
return [list]
}
doc_set_page_documentation_mode 1
#ns_log notice "Sourcing $::acs::rootdir/$path in documentation mode"
ad_try {
#
# Sourcing in documentation mode fills "doc_elements"
#
source "$::acs::rootdir/$path"
} on error {errorMsg} {
#
# This is a strange construct: in case, the ::$errorInfo
# starts with ad_page_contract, we get the documentation
# elements from the $errorMsg
#
if {[regexp {^ad_page_contract documentation} $::errorInfo] } {
array set doc_elements $errorMsg
} else {
ns_log notice "api_read_script_documentation: got unexpected result while sourcing $::acs::rootdir/$path $errorMsg"
return -code error $errorMsg
}
} finally {
doc_set_page_documentation_mode 0
}
return [array get doc_elements]
}
ad_proc -public api_script_documentation {
{ -format text/html }
path
} {
Generates formatted documentation for a content page. Sources the file
to obtain the comment or contract at the beginning.
@param format the type of documentation to generate. Currently, only
text/html
is supported.
@param path the path of the Tcl file to examine, relative to the
OpenACS root directory.
@return the formatted documentation string.
@error if the file does not exist.
} {
append out "
DB Query file\n" return $out } elseif { [file extension $path] ne ".tcl" } { set mime_type [ns_guesstype $path] if {[string match image/* $mime_type] && [regexp {packages/(.*)/www/resources/(.*)$} $path . pkg name]} { set preview "
" } else { set preview "" } append out "
\n" return $out } ad_try { array set doc_elements [api_read_script_documentation $path] } on error {errorMsg} { append out "Delivered as $mime_type$preview
\n" return $out } array set params [list] if { [info exists doc_elements(param)] } { foreach param $doc_elements(param) { if { [regexp {^([^ \t]+)[ \t](.+)$} $param "" name value] } { set params($name) $value } } } append out "Unable to read $path: [ns_quotehtml $errorMsg]
" if { [info exists doc_elements(main)] } { append out" return $out } ad_proc -public api_library_documentation { { -format text/html } path } { Generates formatted documentation for a Tcl library file (just the header, describing what the library does). @param path the path to the file, relative to the OpenACS path root. } { if { $format ne "text/html" } { return -code error "Only text/html documentation is currently supported" } set out "[lindex $doc_elements(main) 0] } else { append out "
Does not contain a contract." } append out "
\n" # XXX: This does not work at the moment. -bmq # if { [array size doc_elements] > 0 } { # array set as_flags $doc_elements(as_flags) # array set as_filters $doc_elements(as_filters) # array set as_default_value $doc_elements(as_default_value) # if { [llength $doc_elements(as_arg_names)] > 0 } { # append out "
- Query Parameters:
- \n" # foreach arg_name $doc_elements(as_arg_names) { # append out "$arg_name" # set notes [list] # if { [info exists as_default_value($arg_name)] } { # lappend notes "defaults to
\n" # } # if { [info exists doc_elements(type)] && $doc_elements(type) ne "" } { # append out "\"$as_default_value($arg_name)\"
" # } # lappend notes {*}$as_flags($arg_name) # foreach filter $as_filters($arg_name) { # set filter_proc [ad_page_contract_filter_proc $filter] # lappend notes "$filter" # } # if { [llength $notes] > 0 } { # append out " ([join $notes ", "])" # } # if { [info exists params($arg_name)] } { # append out " - $params($arg_name)" # } # append out "
\n" # } # append out "- Returns Type:
- $doc_elements(type)\n" # } # # XXX: Need to support "Returns Properties:" # } append out "
- Location:
- $path\n" append out [::apidoc::format_common_elements doc_elements] append out "
\n" } return $out } ad_proc -deprecated -public api_type_documentation { type } { Deprecated: this was part of a feature which used to react to the 'type' property set in ad_page_contract's documentation and generate an extra link in /api-doc/package-view, but currently no upstream script seems to specify this value and no code seems to create necessary 'doc_type_doc' nsv @see /packages/acs-api-browser/www/type-view.tcl @return HTML fragment of the API docs. } { array set doc_elements [nsv_get doc_type_doc $type] append out "\n" append out [lindex $doc_elements(main) 0] append out "
\n" append out "
\n" append out "- Location:\n
- [ns_quotehtml $path]\n" if { [info exists doc_elements(creation-date)] } { append out "
- Created:\n
- [lindex $doc_elements(creation-date) 0]\n" } if { [info exists doc_elements(author)] } { append out "
- Author[expr {[llength $doc_elements(author)] > 1 ? "s" : ""}]:\n" foreach author $doc_elements(author) { append out "
- [::apidoc::format_author $author]\n" } } if { [info exists doc_elements(cvs-id)] } { append out [subst {
- CVS Identification:
[ns_quotehtml [lindex $doc_elements(cvs-id) 0]]
}] } append out "
[lindex $doc_elements(main) 0]\n" return $out } ad_proc -public api_proc_documentation { -format -script:boolean -source:boolean -xql:boolean -label {-first_line_tag
- Properties:
- " array set property_doc [list] if { [info exists doc_elements(property)] } { foreach property $doc_elements(property) { if { [regexp {^([^ \t]+)[ \t](.+)$} $property "" name value] } { set property_doc($name) $value } } } foreach property [lsort [array names properties]] { set info $properties($property) set type [lindex $info 0] append out "$property" if { $type ne "onevalue" } { append out " ($type)" } if { [info exists property_doc($property)] } { append out " - $property_doc($property)" } if {$type eq "onerow"} { append out "
\n" } else { set columns [lindex $info 1] append out "\n" foreach column $columns { append out "
\n" } } append out \ [::apidoc::format_common_elements doc_elements] \ "- $column" if { [info exists property_doc($property.$column)] } { append out " - $property_doc($property.$column)" } } append out "
- Location:
- $doc_elements(script)\n" \ "
Defined in $doc_elements(script)
}] } if { $doc_elements(deprecated_p) } { append intro_out "Deprecated." if { $doc_elements(warn_p) } { append intro_out " Invoking this procedure generates a warning." } append intro_out "
\n" } set main [lindex $doc_elements(main) 0] if {$main ne ""} { append intro_out "
[lindex $doc_elements(main) 0]\n
\n" } set blocks_out "
\"[ns_quotehtml $default_values($switch)]\"
)"
}
if {"required" in $flags($switch)} {
append blocks_out " (required)"
} else {
append blocks_out " (optional)"
}
append blocks_out "\"$default_values($positional)\"
)"
}
}
if { [info exists params($positional)] } {
append blocks_out " - $params($positional)"
}
append blocks_out "[::apidoc::tcl_to_html $proc_name]
[ns_quotehtml [api_get_body $proc_name]]
$content"} append there [subst {
$content"} set href [export_vars -base content-page-view {{source_p 1} {path $xql_fn}}] append there [subst {
$content"} set href [export_vars -base content-page-view {{source_p 1} {path $xql_fn}}] append there [subst {
$out_sections} # No "see also" yet. return $out } ad_proc api_proc_pretty_name { -link:boolean -include_debug_controls:boolean -hints_only:boolean {-proc_type ""} -label proc } { @return a pretty version of a proc name @param label the label printed for the proc in the header line @param link provide a link to the documentation pages } { if {$hints_only_p} { set out "" set debug_html "" } else { if {![info exists label]} { set label $proc } if { $link_p } { append out [subst {$label}] } else { append out $label } set debug_html [expr {$include_debug_controls_p && [info commands ::xo::api] ne "" ? [::xo::api debug_widget $proc] : ""}] } if {[nsv_exists api_proc_doc $proc]} { set doc_elements [nsv_get api_proc_doc $proc] } else { set doc_elements "" } set hints {} if {$proc_type ne ""} { lappend hints $proc_type } if {[dict exists $doc_elements protection]} { lappend hints [dict get $doc_elements protection] } if {[dict exists $doc_elements deprecated_p] && [dict get $doc_elements deprecated_p] } { lappend hints deprecated } if {[llength $hints] > 0} { if {$out ne ""} { append out " " } append out "([join $hints {, }])" } append out $debug_html return $out } ad_proc -public api_apropos_functions { string } { @return the functions in the system that contain string in their name and have been defined using ad_proc. } { set matches [list] foreach function [nsv_array names api_proc_doc] { if {[string match -nocase "*$string*" $function]} { array set doc_elements [nsv_get api_proc_doc $function] lappend matches [list $function $doc_elements(positionals)] } } return $matches } ad_proc -public api_add_to_proc_doc { -proc_name:required -property:required -value:required } { Add a certain value to a property in the proc doc of the specified proc. @author Gustaf Neumann @param proc_name name is fully qualified name without leading colons proc procs, XOTcl methods are a triple with the fully qualified class name, then proc|instproc and then the method name. @param property name of property such as "testcase" @param value value of the property } { if {[nsv_exists api_proc_doc $proc_name]} { set d [nsv_get api_proc_doc $proc_name] # # Make sure, not adding value multiple times (e.g. on # reloads). Probably clearing on redefinition would be an # option, but then we have to make sure that the test cases # are reloaded as well. # if {[dict exists $d $property]} { set must_update [expr {$value ni [dict get $d $property]}] } else { set must_update 1 } if {$must_update} { dict lappend d $property $value nsv_set api_proc_doc $proc_name $d #ns_log notice "adding property $property with value $value to proc_doc of $proc_name" } } else { nsv_set api_proc_doc $proc_name [list $property $value] ns_log warning "api_add_to_proc_doc: no proc_doc available for $proc_name" } } ad_proc -private api_called_proc_names { {-body} -proc_name:required } { Return list of procs called by the specified procname handle. @author Gustaf Neumann @param proc_name name is fully qualified name without leading colons proc procs, XOTcl methods are a triple with the fully qualified class name, then proc|instproc and then the method name. } { if {[info exists body]} { # # Get the calling information directly from the body, when # e.g. the information is not in the procdoc nsv. This is # e.g. necessary, when getting calling info from *-init.tcl # files. # set body [apidoc::tclcode_to_html $body] } else { # # Get calling info from prettified proc body # try { ::apidoc::tcl_to_html $proc_name } on ok {result} { set body $result #ns_log notice "api_called_proc_names <$proc_name> got body <$body>" } on error {errorMsg} { ns_log warning "api_called_proc_names: cannot obtain body of '$proc_name' via ::apidoc::tcl_to_html: $errorMsg" return "" } } dom parse -html
$body
doc $doc documentElement root set called {} foreach a [$root selectNodes //a] { set href [$a getAttribute href] # # When the href points to a proc, record this as calling info # if {[regexp {/api-doc/proc-view[?]proc=(.*)&} $href . called_proc]} { set called_proc [string trimleft [ns_urldecode $called_proc] :] lappend called $called_proc } } #ns_log notice "api_called_proc_names: <$proc_name> calls $called" return [lsort -unique $called] } ad_proc -private api_add_calling_info_to_procdoc {{proc_name "*"}} { Add the calling information (what a the functions called by this proc_name) to the collected proc_doc information. @author Gustaf Neumann } { if {$proc_name eq "*"} { set proc_names [nsv_array names api_proc_doc] } else { set proc_names [list $proc_name] } # # Get calling information from init files # set init_files packages/acs-bootstrap-installer/bootstrap.tcl foreach package_key [apm_enabled_packages] { foreach file [apm_get_package_files -package_key $package_key -file_types {tcl_init content_page include_page}] { if {[file extension $file] eq ".tcl"} { lappend init_files packages/$package_key/$file } } } foreach init_file $init_files { set file_contents [template::util::read_file $::acs::rootdir/$init_file] foreach called [api_called_proc_names -proc_name $init_file -body $file_contents] { api_add_to_proc_doc \ -proc_name $called \ -property calledby \ -value $init_file } } # # Get calling information from procs # foreach proc_name $proc_names { if {[regexp {^_([^_]+)__(.*)$} $proc_name . package_key testcase_id]} { # # Turn this test-case cross-check just on, when needed for debugging. # if {0} { set calls {} foreach call [api_called_proc_names -proc_name $proc_name] { # # Ignore aa_* calls (the testing infrastructure is # explicitly tested). # if {[string match "aa_*" $call]} continue # # Check, if these cases are already covered. # set covered 0 if {[nsv_exists api_proc_doc $call]} { set called_proc_doc [nsv_get api_proc_doc $call] #ns_log notice "procdoc for $call has testcase [dict exists $called_proc_doc testcase]" if {[dict exists $called_proc_doc testcase]} { set testcase_pair [list $testcase_id $package_key] ns_log notice "$call is covered by cases [dict get $called_proc_doc testcase]\ - new case included [expr {$testcase_pair in [dict get $called_proc_doc testcase]}]" set covered [expr {$testcase_pair in [dict get $called_proc_doc testcase]}] } } # # Only list remaining calls to suggestions. # if {!$covered} { lappend calls $call } } if {[llength $calls] > 0} { ns_log notice "potential test_cases $package_key $testcase_id $package_key: $calls" } } } else { foreach called [api_called_proc_names -proc_name $proc_name] { api_add_to_proc_doc \ -proc_name $called \ -property calledby \ -value $proc_name } } } } ad_proc -private api_call_graph_snippet { -proc_name:required {-dpi 72} {-format svg} {-maxnodes 5} {-textpointsize 12.0} } { Return a source code for dot showing a local call graph snippet, showing direct callers and directly called functions @author Gustaf Neumann } { set dot_code "" # # Include calls from test cases # set doc [nsv_get api_proc_doc $proc_name] if {[dict exists $doc testcase]} { set nodes "" set edges "" foreach testcase_pair [lrange [lsort [dict get $doc testcase]] 0 $maxnodes-1] { lassign $testcase_pair testcase_id package_key set testcase_node test_$testcase_id set url [api_test_case_url $testcase_pair] set props "" append props \ [subst {URL="$url", margin=".2,0", shape=none, tooltip="Testcase $testcase_id of package $package_key", }] \ [subst {label=<$testcase_id\n"]
}
}
return $matches
}
ad_proc -public api_get_body {proc_name} {
This function returns the body of a Tcl proc or an XOTcl method.
@param proc_name the name spec of the proc
@return body of the specified proc
} {
#
# In case the proc_name contains magic chars, these have to be
# escaped for Tcl commands expecting a pattern (e.g. "info procs")
#
regsub -all {([?*])} $proc_name {\\\1} proc_name_pattern
if {[info commands ::xo::api] ne ""
&& [regexp {^(.*) (inst)?proc (.*)$} $proc_name match obj prefix method]} {
if {[regexp {^(.*) (.*)$} $obj match scope obj]} {
if {[::xo::api scope_eval $scope ::nsf::is object $obj]} {
return [::xo::api get_method_source $scope $obj $prefix $method]
}
} else {
if {[::nsf::is object $obj]} {
return [::xo::api get_method_source "" $obj $prefix $method]
}
}
return ""
} elseif {[info commands ::xo::api] ne ""
&& [regexp {^([^ ]+) (Class|Object) (.*)$} $proc_name . thread kind obj]} {
return [::xo::api get_object_source $thread $obj]
} elseif {[info commands ::xo::api] ne ""
&& [regexp {(Class|Object) (.*)$} $proc_name . kind obj]} {
return [::xo::api get_object_source "" $obj]
} elseif {[info procs $proc_name_pattern] ne ""} {
return [info body $proc_name]
} elseif {[info procs ::nsf::procs::$proc_name_pattern] ne ""} {
return [::nx::Object info method body ::nsf::procs::$proc_name]
} else {
return "No such Tcl-proc '$proc_name'"
}
}
namespace eval ::apidoc {
ad_proc -private get_xql_snippet {-proc_name -xql_file} {
@return matching xql snippet for specified proc_name
} {
set content [template::util::read_file $::acs::rootdir/$xql_file]
# make parsable XML, replace "partialquery" by "fullquery"
set prepared_content [db_qd_internal_prepare_queryfile_content $content]
dom parse -simple $prepared_content doc
$doc documentElement root
set result ""
foreach q [$root selectNodes //fullquery] {
if {[string match "$proc_name.*" [$q getAttribute name]]} {
append result [$q asXML -indent 4] \n
}
}
set readable_xml [string map {< < > > & &} [string trimright $result]]
return [ns_quotehtml $readable_xml]
}
ad_proc -public format_see { see } {
Takes the value in the argument "see" and possibly formats it
into a link that will give the user more info about that
resource
@param see a string expected to contain the resource to format
@return the html string representing the resource
} {
#regsub -all {proc *} $see {} see
set see [string trim $see]
if {[nsv_exists api_proc_doc $see]} {
set href [export_vars -base /api-doc/proc-view {{proc $see}}]
return [subst {$see}]
}
set see [string trimleft $see :]
if {[nsv_exists api_proc_doc $see]} {
set href [export_vars -base /api-doc/proc-view {{proc $see}}]
return [subst {$see}]
}
if {[string match "/doc/*" $see]
|| [util_url_valid_p $see]} {
return [subst {$see}]
}
if {[file exists "$::acs::rootdir${see}"]} {
set href [export_vars -base content-page-view {{source_p 1} {path $see}}]
return [subst {$see}]
}
return $see
}
ad_proc -public format_author { author_string } {
Extracts information about the author and formats it into an
HTML string.
@param author_string author information to format. 3 kind of
formats are expected: email (a mailto link to the email
is generated), whitespace-separated couple "
Known Issues:
<dt>
and
<dd>
tags).
@param authors the list of author strings.
@return the formatted list, or an empty string if there are no authors.
} {
if { [llength $authors] == 0 } {
return ""
}
append out "[ns_quotehtml [lindex $doc_elements(cvs-id) 0]]
See Also:\n"
foreach see $sees {
append out "
\n"
return $out
}
ad_proc -private first_sentence { string } {
@return the first sentence of a string.
} {
if { [regexp {^(.+?\.)\s} $string "" sentence] } {
return $sentence
}
return $string
}
ad_proc -private set_public {
version_id
{ public_p "" }
} {
Gets or sets the user's public/private preferences for a given
package.
@param version_id the version of the package
@param public_p if empty, return the user's preferred setting or the default (1)
if no preference found. If not empty, set the user's preference to public_p
@return public_p
} {
set public_property_name "api,package,$version_id,public_p"
if { $public_p eq "" } {
set public_p [ad_get_client_property acs-api-browser $public_property_name]
if { $public_p eq "" } {
set public_p 1
}
} else {
ad_set_client_property acs-api-browser $public_property_name $public_p
}
return $public_p
}
ad_proc -private ad_sort_by_score_proc {l1 l2} {
basically a -1,0,1 result comparing the second element of the
list inputs then the first. (second is int)
} {
if {[lindex $l1 1] eq [lindex $l2 1]} {
return [string compare [lindex $l1 0] [lindex $l2 0]]
} else {
if {[lindex $l1 1] > [lindex $l2 1]} {
return -1
} else {
return 1
}
}
}
ad_proc -private ad_sort_by_second_string_proc {l1 l2} {
basically a -1,0,1 result comparing the second element of the
list inputs then the first (both strings)
} {
if {[lindex $l1 1] eq [lindex $l2 1]} {
return [string compare [lindex $l1 0] [lindex $l2 0]]
} else {
return [string compare [lindex $l1 1] [lindex $l2 1]]
}
}
ad_proc -private ad_sort_by_first_string_proc {l1 l2} {
basically a -1,0,1 result comparing the second element of the
list inputs then the first. (both strings)
} {
if {[lindex $l1 0] eq [lindex $l2 0]} {
return [string compare [lindex $l1 1] [lindex $l2 1]]
} else {
return [string compare [lindex $l1 0] [lindex $l2 0]]
}
}
ad_proc -private ad_keywords_score {keywords string_to_search} {
@return Number of keywords found in string to search.
No additional score for repeats.
} {
# turn keywords into space-separated things
# replace one or more commands with a space
regsub -all {,+} $keywords " " keywords
set score 0
foreach word $keywords {
# turns out that "" is never found in a search, so we
# don't really have to special case $word eq ""
if {[string match -nocase "*$word*" $string_to_search]} {
incr score
}
}
return $score
}
ad_proc -private is_object {scope proc_name} {
Checks, whether the specified argument is an xotcl object.
Does not cause problems when xotcl is not loaded.
@return boolean value
} {
set result 0
catch {set result [::xo::api isobject $scope $proc_name]}
return $result
}
ad_proc -private tcl_to_html {proc_name} {
Given a proc name, 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.
@author Jamie Rasmussen (jrasmuss@mle.ie)
@param proc_name procedure to format in HTML
} {
if {[info commands ::xo::api] ne ""} {
set scope [::xo::api scope_from_proc_index $proc_name]
} else {
set scope ""
}
set proc_namespace ""
regexp {^(::)?(.*)::[^:]+$} $proc_name match colons proc_namespace
return [tclcode_to_html -scope $scope -proc_namespace $proc_namespace [api_get_body $proc_name]]
}
ad_proc -private length_var {data} {
@return Length of a variable name.
} {
if {[regexp -indices {^\$\{[^\}]+\}} $data found]} {
return [lindex $found 1]
} elseif {[regexp -indices {^\$[A-Za-z0-9_:]+(\([\$A-Za-z0-9_\-/]+\))?} $data found]} {
return [lindex $found 1]
}
return 0
}
ad_proc -private length_proc {data} {
@return Length of a command name.
} {
if {[regexp -indices {^(::)?[A-Za-z0-9][:\.A-Za-z0-9_@]+} $data found]} {
return [lindex $found 1]
}
return 0
}
ad_proc -private length_string {data} {
@eturn length of subexpression, from open to close quote inclusive.
} {
regexp -indices {[^\\]\"} $data match
return [expr {[lindex $match 1]+1}]
}
ad_proc -private length_braces {data} {
@return length of subexpression, from open to close brace inclusive.
Doesn't deal with unescaped braces in substrings.
} {
set i 1
for {set count 1} {1} {incr i} {
if {[string index $data $i] eq "\\"} {
incr i
} elseif {[string index $data $i] eq "\{"} {
incr count
} elseif {[string index $data $i] eq "\}"} {
incr count -1
}
if {!$count} { break }
}
return [expr {$i+1}]
}
ad_proc -private length_spaces {data} {
@return Number of spaces until next subexpression.
} {
regexp -indices {\s+} $data match
return [expr {[lindex $match 1]+1}]
}
ad_proc -private length_exp {data} {
@return length of a generic subexpression.
} {
if {[string index $data 0] eq "\""} {
return [length_string $data]
} elseif {[string index $data 0] eq "\{"} {
return [length_braces $data]
} elseif {[string index $data 0] eq " "} {
return [length_spaces $data]
}
if { [regexp -indices { } $data match] } {
return [lindex $match 1]
}
return 0
}
ad_proc -private length_regexp {data} {
Calculate how much text we should ignore.
@return length in characters.
} {
set i 0
set found_regexp 0
set curchar [string index $data $i]
while {$curchar ne "\$" && $curchar ne "\[" &&
($curchar ne "\{" || !$found_regexp)} {
if {$curchar eq "\{"} {set found_regexp 1}
if {[string range $data $i $i+5] eq "-start"} {
incr i [length_exp [string range $data $i end]] ;# -start
incr i [length_exp [string range $data $i end]] ;# spaces
incr i [length_exp [string range $data $i end]] ;# expression - it could be a var
}
incr i [length_exp [string range $data $i end]]
set curchar [string index $data $i]
}
return [expr {$i - 1}]
}
ad_proc -private search_on_webindex {-page -host -root -proc} {
Search for a matching link in the page and return the absolute
link if found. Avoid in-page links (starting with "#")
@param page HTML page
@param host for completing URLs starting with no "/"
@param root for completing URLs starting with a "/"
@param proc name of proc as used in link label
} {
set url ""
if { [regexp "\"'\]+)\[\"'\]\[^>\]*>$proc" \
$page match relative_url] } {
if {[string match "/*" $relative_url]} {
set url $host$relative_url
} else {
set url $root$relative_url
}
}
return $url
}
ad_proc -private get_doc_url {-cmd -index -root -host} {
foreach i $index r $root {
set result [util_memoize [list ::util::http::get -url $i]]
set page [dict get $result page]
#
# Since man pages contain often a summary of multiple commands, try
# abbreviation in case the full name is not found (e.g. man page "nsv"
# contains "nsv_array", "nsv_set" etc.)
#
set url ""
for {set i [string length $cmd]} {$i > 1} {incr i -1} {
set proc [string range $cmd 0 $i]
set url [apidoc::search_on_webindex \
-page $page \
-root $r \
-host $host \
-proc $proc]
if {$url ne ""} {
ns_log notice "=== cmd <$cmd> --> $url"
return $url
}
}
}
ns_log notice "=== cmd <$cmd> not found on <$index> root <$root> host <$host>"
return ""
}
ad_proc -private pretty_token {kind token} {
Encode the specified token in HTML
} {
return "$token"
}
ad_proc -public tclcode_to_html {{-scope ""} {-proc_namespace ""} script} {
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.
@param script script to be formatted in HTML
} {
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 {[info commands ::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 & "&" < "<" > ">"] \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 \"
set in_quotes 0
} else {
append html "" \"
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 ""
}
append html "#"
}
"\n" {
set proc_ok 1
if {$in_quotes} {
set proc_ok 0
}
if {$in_comment} {
append html
}
append html "\n"
set in_comment 0
}
"\{" -
";" {
if {!$in_quotes} {
set proc_ok 1
}
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 " "
}
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 \
"" \
[pretty_token proc ad_proc] \
[string range $data $i+7 $comment_start] \
"" \
[string range $data $comment_start+1 $comment_end-1] \
"\}"
set i $comment_end
continue
}
}
}
}
}
if {$proc_name in {* @ ?}} {
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=$proc_name"
append html "" \
[pretty_token keyword $proc_name]
#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 "" \
[pretty_token proc $proc_name]
} elseif {[string match "*__arg_parser" $proc_name]} {
append html [pretty_token helper $proc_name]
} elseif {$proc_namespace ne ""
&& [info commands ::${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 "" \
[pretty_token object $proc_name]
} else {
set url [api_proc_url ${proc_namespace}::${proc_name}]
append html "" \
[pretty_token proc $proc_name]
}
} elseif {[info commands ::$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 "" \
[pretty_token object $proc_name]
} else {
set url [api_proc_url $proc_name]
append html "" \
[pretty_token proc $proc_name]
}
} else {
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]
}
ad_proc -private xql_links_list { {-include_compiled 0} path } {
@return list of xql files related to Tcl script file
@param path path and filename from $::acs::rootdir
} {
set linkList [list]
set paths $path
set root_path [file rootname $path]
set themed_path [template::themed_template $root_path]
if {$themed_path ne $root_path} {
lappend paths $themed_path
}
foreach path $paths {
set filename $::acs::rootdir/$path
set path_dirname [file dirname $path]
set file_dirname [file dirname $filename]
set file_rootname [file rootname [file tail $filename]]
regsub {(-oracle|-postgresql)$} $file_rootname {} file_rootname
lappend files {*}[glob -nocomplain \
-directory $file_dirname \
"${file_rootname}{,-}{,oracle,postgresql}.{adp,tcl,xql}" ]
}
foreach file [lsort -decreasing $files] {
set path [ns_urlencode $path_dirname/[file tail $file]]
set link [export_vars -base content-page-view {{source_p 1} path}]
set display_file [string range $file [string length $::acs::rootdir]+1 end]
lappend linkList [list filename $display_file link $link]
if {$include_compiled && [file extension $file] eq ".adp"} {
set link [export_vars -base content-page-view {{source_p 1} {compiled_p 1} path}]
lappend linkList [list filename "$display_file (compiled)" link $link]
}
}
return $linkList
}
ad_proc -private sanitize_path { {-prefix packages} path } {
Return a sanitized path. Cleans path from directory traversal
attacks and checks, if someone tries to access content outside
of the specified prefix.
@return sanitized path
} {
set path [ns_normalizepath $path]
if {![string match "/$prefix/*" $path]} {
set filename "$::acs::rootdir/$path"
ns_log notice [subst {INTRUDER ALERT:\n\nsomesone tried to snarf '$filename'!
file exists: [file exists $filename] user_id: [ad_conn user_id] peer: [ad_conn peeraddr]
}]
set path $prefix/$path
}
return $path
}
}
####################
#
# Linking to api-documentation
#
####################
#
# procs for linking to libraries, pages, etc, should go here too.
#
ad_proc api_proc_url { proc } {
@return the URL of the page that documents the given proc.
@author Lars Pind (lars@pinds.com)
@creation-date 14 July 2000
} {
return "/api-doc/proc-view?proc=[ns_urlencode $proc]&source_p=1"
}
ad_proc -private api_proc_doc_url {-proc_name -source_p -version_id} {
Return the procdic url from procname and optionally from source_p and version_id
} {
if {[string range $proc_name 0 0] eq " " && [lindex $proc_name 0] in {Object Class}} {
set object [lindex $proc_name end]
set url [export_vars -base /xotcl/show-object {
object {show_source 1} {show_methods 1}
}]
} else {
set url [export_vars -base /api-doc/proc-view -no_empty {
{proc $proc_name} source_p version_id
}]
}
return $url
}
ad_proc -deprecated api_proc_link { proc } {
@return full HTML link to the documentation for the proc.
Deprecated as it is broken because api_proc_url accepts (now?)
different arguments
@see api_proc_url
@author Lars Pind (lars@pinds.com)
@creation-date 14 July 2000
} {
return "$proc"
}
ad_proc -private api_test_case_url {testcase_pair} {
Return the testcase url from testcase_pair, consisting of
testcase_id and package_key.
} {
lassign $testcase_pair testcase_id package_key
return [export_vars -base /test/admin/testcase {
testcase_id package_key {showsource 1}
}]
}
#
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End: