Index: openacs-4/packages/acs-api-browser/acs-api-browser.info =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-api-browser/acs-api-browser.info,v diff -u -N -r1.39 -r1.40 --- openacs-4/packages/acs-api-browser/acs-api-browser.info 17 Jul 2018 21:15:20 -0000 1.39 +++ openacs-4/packages/acs-api-browser/acs-api-browser.info 25 Jul 2018 13:40:15 -0000 1.40 @@ -7,7 +7,7 @@ t t - + OpenACS Interactive documentation for the Tcl and SQL APIs. 2017-08-06 @@ -17,7 +17,7 @@ 3 On line interactive documentation for the locally installed Tcl and SQL APIs. Links to the Tcl core and NaviServer/AOLServer online documentation as well. - + Index: openacs-4/packages/acs-api-browser/tcl/acs-api-documentation-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-api-browser/tcl/acs-api-documentation-procs.tcl,v diff -u -N -r1.50 -r1.51 --- openacs-4/packages/acs-api-browser/tcl/acs-api-documentation-procs.tcl 23 Jul 2018 17:45:09 -0000 1.50 +++ openacs-4/packages/acs-api-browser/tcl/acs-api-documentation-procs.tcl 25 Jul 2018 13:40:15 -0000 1.51 @@ -376,9 +376,17 @@ @return the formatted documentation string. @error if the procedure is not defined. } { + # + # Sanitize input + # + if {[string match *::::* $proc_name]} { + ad_log warning "api_proc_documentation: received invalid proc_name <$proc_name>, try to sanitize" + regsub -all {::::} $proc_name :: proc_name + } if { $format ne "text/html" && $format ne "text/plain" } { return -code error "Only text/html and text/plain documentation are currently supported" } + array set doc_elements {flags "" default_values "" switches "" positionals "" varargs_p 0 script "" deprecated_p 0 main ""} array set doc_elements [nsv_get api_proc_doc $proc_name] array set flags $doc_elements(flags) array set default_values $doc_elements(default_values) @@ -492,126 +500,109 @@ append intro_out "

[lindex $doc_elements(main) 0]\n

\n" } - # - # Make first a quick check, and if it fails, double check details - # - set haveBlocks [expr {[llength $doc_elements(switches)] > 0 - || [llength $doc_elements(positionals)] > 0}] - if {$haveBlocks == 0} { - foreach e {param option return error author creation-date change-log cvs-id see} { - if {[info exists doc_elements($e)] && $doc_elements($e) ne ""} { - set haveBlocks 1 - break + set blocks_out "

\n" + + if { [info exists doc_elements(param)] } { + foreach param $doc_elements(param) { + if { [regexp {^([^ \t\n]+)[ \t\n]+(.*)$} $param "" name value] } { + set params($name) $value } } } - if {$haveBlocks} { - set blocks_out "
\n" + if { [llength $doc_elements(switches)] > 0 } { + append blocks_out "
Switches:
\n" + foreach switch $doc_elements(switches) { + append blocks_out "
-$switch" + if {"boolean" in $flags($switch)} { + append blocks_out " (boolean)" + } - if { [info exists doc_elements(param)] } { - foreach param $doc_elements(param) { - if { [regexp {^([^ \t\n]+)[ \t\n]+(.*)$} $param "" name value] } { - set params($name) $value - } + if { [info exists default_values($switch)] + && $default_values($switch) ne "" + } { + append blocks_out " (defaults to \"[ns_quotehtml $default_values($switch)]\")" } - } - if { [llength $doc_elements(switches)] > 0 } { - append blocks_out "
Switches:
\n" - foreach switch $doc_elements(switches) { - append blocks_out "
-$switch" - if {"boolean" in $flags($switch)} { - append blocks_out " (boolean)" - } - - if { [info exists default_values($switch)] - && $default_values($switch) ne "" - } { - append blocks_out " (defaults to \"[ns_quotehtml $default_values($switch)]\")" - } - - if {"required" in $flags($switch)} { - append blocks_out " (required)" - } else { - append blocks_out " (optional)" - } - append blocks_out "
" - if { [info exists params($switch)] } { - append blocks_out "
$params($switch)
" - } + if {"required" in $flags($switch)} { + append blocks_out " (required)" + } else { + append blocks_out " (optional)" } - append blocks_out "
\n" + append blocks_out "" + if { [info exists params($switch)] } { + append blocks_out "
$params($switch)
" + } } + append blocks_out "
\n" + } - if { [llength $doc_elements(positionals)] > 0 } { - append blocks_out "
Parameters:
\n" - foreach positional $doc_elements(positionals) { - append blocks_out "$positional" - if { [info exists default_values($positional)] } { - if { $default_values($positional) eq "" } { - append blocks_out " (optional)" - } else { - append blocks_out " (defaults to \"$default_values($positional)\")" - } + if { [llength $doc_elements(positionals)] > 0 } { + append blocks_out "
Parameters:
\n" + foreach positional $doc_elements(positionals) { + append blocks_out "$positional" + if { [info exists default_values($positional)] } { + if { $default_values($positional) eq "" } { + append blocks_out " (optional)" + } else { + append blocks_out " (defaults to \"$default_values($positional)\")" } - if { [info exists params($positional)] } { - append blocks_out " - $params($positional)" - } - append blocks_out "
\n" } - append blocks_out "
\n" + if { [info exists params($positional)] } { + append blocks_out " - $params($positional)" + } + append blocks_out "
\n" } + append blocks_out "\n" + } - # @option is used in template:: and cms:: (and maybe should be used in some other - # things like ad_form which have internal arg parsers. although an option - # and a switch are the same thing, just one is parsed in the proc itself rather than - # by ad_proc. + # @option is used in template:: and cms:: (and maybe should be used in some other + # things like ad_form which have internal arg parsers. although an option + # and a switch are the same thing, just one is parsed in the proc itself rather than + # by ad_proc. - if { [info exists doc_elements(option)] } { - append blocks_out "Options:
" - foreach param $doc_elements(option) { - if { [regexp {^([^ \t]+)[ \t](.+)$} $param "" name value] } { - append blocks_out "
-$name
$value
" - } + if { [info exists doc_elements(option)] } { + append blocks_out "Options:
" + foreach param $doc_elements(option) { + if { [regexp {^([^ \t]+)[ \t](.+)$} $param "" name value] } { + append blocks_out "
-$name
$value
" } - append blocks_out "
" } + append blocks_out "
" + } - if { [info exists doc_elements(return)] } { - append blocks_out "
Returns:
[join $doc_elements(return) "
"]
\n" - } + if { [info exists doc_elements(return)] } { + append blocks_out "
Returns:
[join $doc_elements(return) "
"]
\n" + } - if { [info exists doc_elements(error)] } { - append blocks_out "
Error:
[join $doc_elements(error) "
"]
\n" - } + if { [info exists doc_elements(error)] } { + append blocks_out "
Error:
[join $doc_elements(error) "
"]
\n" + } - append blocks_out [::apidoc::format_common_elements doc_elements] + append blocks_out [::apidoc::format_common_elements doc_elements] - append blocks_out "

Testcases:
\n" + set callgraph [api_inline_svg_from_dot [api_call_graph_snippet -proc_name $proc_name -maxnodes 5]] + if {$callgraph ne ""} { + append blocks_out "

Partial Call Graph (max 5 caller/called nodes):
$callgraph
\n" + } + + append blocks_out "

Testcases:
\n" - if {[info exists doc_elements(testcase)]} { - set cases {} - set package_key "" - regexp {packages/([^/]+)/} $doc_elements(script) . package_key - foreach testcase_id $doc_elements(testcase) { - set url [export_vars -base /test/admin/testcase { - testcase_id package_key {showsource 1} - }] - lappend cases [subst {[ns_quotehtml $testcase_id]}] - } - append blocks_out "[join $cases {, }]" - } else { - append blocks_out "No testcase defined." + if {[info exists doc_elements(testcase)]} { + set cases {} + foreach testcase_pair $doc_elements(testcase) { + set url [api_test_case_url $testcase_pair] + lappend cases [subst {[ns_quotehtml [lindex $testcase_pair 0]]}] } - append blocks_out "
\n
\n" - + append blocks_out [join $cases {, }] } else { - set blocks_out "" + append blocks_out "No testcase defined." } + append blocks_out "\n
\n" + if { $source_p } { if {[parameter::get_from_package_key \ -package_key acs-api-browser \ @@ -699,6 +690,7 @@ ad_proc api_proc_pretty_name { -link:boolean -include_debug_controls:boolean + -hints_only:boolean {-proc_type ""} -label proc @@ -707,28 +699,49 @@ @param label the label printed for the proc in the header line @param link provide a link to the documentation pages } { - if {![info exists label]} { - set label $proc + 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 { $link_p } { - append out [subst {$label}] + if {[nsv_exists api_proc_doc $proc]} { + set doc_elements [nsv_get api_proc_doc $proc] } else { - append out $label + set doc_elements "" } - set doc_elements [nsv_get api_proc_doc $proc] - set debug_html [expr {$include_debug_controls_p && [info commands ::xo::api] ne "" - ? [::xo::api debug_widget $proc] : ""}] 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 get $doc_elements deprecated_p]} {lappend hints deprecated} + 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} { - append out " ([join $hints {, }])" + 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. @@ -750,6 +763,7 @@ } { 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. @@ -759,15 +773,266 @@ } { if {[nsv_exists api_proc_doc $proc_name]} { set d [nsv_get api_proc_doc $proc_name] - dict lappend d $property $value - nsv_set api_proc_doc $proc_name $d - ns_log warning "adding property $property with value $value to proc_doc of $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 "no proc_doc available for $proc_name" } } +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} + }] +} +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 +} { + return [export_vars -base /api-doc/proc-view { + {proc $proc_name} source_p version_id + }] +} + + +ad_proc -private api_called_proc_names {proc_name} { + + 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. + +} { + # + # Get calling info from prettified proc body + # + try { + ::apidoc::tcl_to_html $proc_name + } on ok {result} { + set body $result + } on error {errorMsg} { + ns_log warning "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] + } + + 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] { + # + # 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] { + 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 "" + 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 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
(test $package_key)>}] + append nodes [subst -nocommands {"$testcase_id" [$props];\n}] + append edges [subst {"$testcase_id" -> "$proc_name";}] \n + } + append dot_code \ + "subgraph \{\nrank=\"source\";" \ + $nodes \ + "\}\n" \ + $edges + } + if {[dict exists $doc calledby]} { + set edges "" + set nodes "" + foreach caller [lrange [lsort [dict get $doc calledby]] 0 $maxnodes-1] { + set url [api_proc_doc_url -proc_name $caller] + set hints [api_proc_pretty_name -hints_only $caller] + if {$hints ne ""} { + set hints "
$hints" + } + set props "" + append props \ + [subst {URL="$url", margin=".2,0" tooltip="Function calling $proc_name", }] \ + [subst {label=<${caller}>}] + append nodes [subst -nocommands {"$caller" [$props];\n}] + append edges [subst {"$caller" -> "$proc_name";}] \n + } + append dot_code \ + "subgraph \{\nrank=\"same\";" \ + $nodes \ + "\}\n" \ + $edges + } + set edges "" + set nodes "" + foreach called [lrange [api_called_proc_names $proc_name] 0 $maxnodes-1] { + set url [api_proc_doc_url -proc_name $called] + set hints [api_proc_pretty_name -hints_only $called] + if {$hints ne ""} { + set hints "
$hints" + } + ns_log notice "hints <$hints>" + set props "" + append props \ + [subst {URL="$url", margin=".2,0", tooltip="Function called by $proc_name", }] \ + [subst {label=<${called}$hints>}] + append nodes [subst -nocommands {"$called" [$props];\n}] + append edges [subst {"$proc_name" -> "$called";}] \n + } + if {$nodes ne ""} { + append dot_code \ + "subgraph \{\nrank=\"same\";" \ + $nodes \ + "\}\n" \ + $edges + } + ns_log notice \n$dot_code + append result "digraph \{api = $dpi;" $dot_code "\}" +} + +ad_proc -private api_inline_svg_from_dot {dot_code} { + + Transform a dot source code into an inline svg image based on code + from xotcl-core; should be probably move later to a different + place. + + @author Gustaf Neumann +} { + catch {set dot [::util::which dot]} + if {$dot ne ""} { + set tmpnam [ad_tmpnam] + set tmpfile $tmpnam.svg + set f [open $tmpnam.dot w]; puts $f $dot_code; close $f + + #ns_log notice "svg $tmpnam dot $tmpnam.dot" + set f [open "|$dot -Tsvg -o $tmpfile" w]; puts $f $dot_code; close $f + set f [open $tmpfile]; set svg [read $f]; close $f + + # delete the first three lines generated from dot + regsub {^[^\n]+\n[^\n]+\n[^\n]+\n} $svg "" svg + set css { + /*svg g a:link {text-decoration: none;}*/ + div.inner svg {width: 100%; margin: 0 auto;} + svg g polygon {fill: transparent;} + svg g ellipse {fill: #eeeef4;} + } + file delete -- $tmpfile + file delete -- $tmpnam.dot + return "
$svg
" + } +} + ad_proc -public api_describe_function { { -format text/plain } proc Index: openacs-4/packages/acs-api-browser/tcl/api-doc-init.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-api-browser/tcl/api-doc-init.tcl,v diff -u -N --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/acs-api-browser/tcl/api-doc-init.tcl 25 Jul 2018 13:40:15 -0000 1.1 @@ -0,0 +1,24 @@ + +# Decide, whether we want to include calling-info based on static +# analysis in the procdoc structure (what function calls what other +# functions). This calling-info is just relevant for developer +# instances. The computation of the calling-info is not blazingly +# fast, so just do it when needed. +# +# To activate the computation of calling-info, add a section like the +# following to your NaviServer config file. Note, that the +# calling-info is not necessarily complete (it is not always possible +# to derive call calls from the static analysis), also direct calls +# from web pages are not included. +# +# ns_section ns/server/${server}/acs/acs-api-browser +# ns_param IncludeCallingInfo true +# +if {[parameter::get \ + -package_id [apm_package_id_from_key acs-api-browser] \ + -parameter IncludeCallingInfo \ + -default false]} { + ad_schedule_proc -thread t -once t 1 ::api_add_calling_info_to_procdoc +} + +