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 -r1.30 -r1.31 --- openacs-4/packages/acs-api-browser/tcl/acs-api-documentation-procs.tcl 19 Jun 2015 19:49:02 -0000 1.30 +++ openacs-4/packages/acs-api-browser/tcl/acs-api-documentation-procs.tcl 7 Aug 2017 23:47:45 -0000 1.31 @@ -16,9 +16,13 @@ # NaviServer at sourceforge # set ns_api_host "http://naviserver.sourceforge.net/" - set ns_api_index "n/naviserver/files/" - set ns_api_root ${ns_api_host}${ns_api_index} - set ns_api_html_index $ns_api_root/commandlist.html + 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 @@ -105,7 +109,7 @@ regsub -all {\#.*$} $line "" line set line [string trim $line] if { $line ne "" } { - set has_contract_p [regexp {(^ad_page_contract\s)|( initialize )} $line match] + set has_contract_p [regexp {(^ad_(page|include)_contract\s)|(Package initialize )} $line] break } } @@ -128,7 +132,7 @@ if {[regexp {^ad_page_contract documentation} $::errorInfo] } { array set doc_elements $error } - if { [info exists doc_elements] } { + if { [array exists doc_elements] } { return [array get doc_elements] } return [list] @@ -347,6 +351,7 @@ -xql:boolean -label {-first_line_tag

} + {-proc_type ""} proc_name } { @@ -371,12 +376,25 @@ array set default_values $doc_elements(default_values) if {![info exists label]} { - set label $proc_name + if {[llength $proc_name] > 1 && [info commands ::xo::api] ne ""} { + set label [::xo::api method_label $proc_name] + } else { + set label $proc_name + } } if { $script_p } { - set pretty_name [api_proc_pretty_name -label $label $proc_name] + set pretty_name [api_proc_pretty_name \ + -include_debug_controls \ + -proc_type $proc_type \ + -label $label \ + $proc_name] } else { - set pretty_name [api_proc_pretty_name -link -label $label $proc_name] + set pretty_name [api_proc_pretty_name \ + -include_debug_controls \ + -link \ + -proc_type $proc_type \ + -label $label \ + $proc_name] } if {[regexp {<([^ >]+)} $first_line_tag match tag]} { set end_tag "" @@ -386,27 +404,30 @@ } append out $first_line_tag$pretty_name$end_tag - if {[regexp {^(.*) (inst)?proc (.*)$} $proc_name match cl prefix method]} { - set xotcl 1 + if {[regexp {^(.*) (inst)?proc (.*)$} $proc_name match cl prefix method] + && [info commands ::xo::api] ne "" + } { + set xotclArgs 1 set scope "" - if {[regexp {^(.+) (.+)$} $cl match scope cl]} { - set cl "$scope do $cl" - } + regexp {^(.+) (.+)$} $cl match scope cl if {$prefix eq ""} { - set pretty_proc_name "[::xotcl::api object_link $scope $cl] $method" + set pretty_proc_name "[::xo::api object_link $scope $cl] $method" } else { - set pretty_proc_name \ - "<instance of\ - [::xotcl::api object_link $scope $cl]> $method" + set pretty_proc_name [subst {<instance of [::xo::api object_link $scope $cl]> $method}] } } else { - set xotcl 0 - set pretty_proc_name $proc_name + set xotclArgs 0 + if {[info commands ::xo::api] ne "" && [::xo::api isclass "" [lindex $proc_name 1]]} { + set name [lindex $proc_name 1] + set pretty_proc_name "[$name info class] [::xo::api object_link {} $name]" + } else { + set pretty_proc_name $proc_name + } } lappend command_line $pretty_proc_name foreach switch $doc_elements(switches) { - if {$xotcl} { + if {$xotclArgs} { if {"boolean" in $flags($switch)} { set value "on|off " } elseif {"switch" in $flags($switch)} { @@ -441,38 +462,44 @@ if { $doc_elements(varargs_p) } { lappend command_line "\[ args... \]" } - append out [util_wrap_list $command_line] "\n
\n" - + append out [util_wrap_list $command_line] + + set intro_out "" if { $script_p } { - append out [subst {

Defined in + append intro_out [subst {

Defined in $doc_elements(script)

}] } if { $doc_elements(deprecated_p) } { - append out "Deprecated." + append intro_out "Deprecated." if { $doc_elements(warn_p) } { - append out " Invoking this procedure generates a warning." + append intro_out " Invoking this procedure generates a warning." } - append out "

\n" + append intro_out "

\n" } - append out "

[lindex $doc_elements(main) 0]\n

\n" - set haveBlocks [expr { - [info exists doc_elements(param)] - || [llength $doc_elements(switches)] > 0 - || [llength $doc_elements(positionals)] > 0 - || [info exists doc_elements(option)] - || [info exists doc_elements(return)] - || [info exists doc_elements(error)] - || [info exists doc_elements(author)] - || [info exists doc_elements(creation-date)] - || [info exists doc_elements(change-log)] - || [info exists doc_elements(cvs-id)] - || [info exists doc_elements(see)] - }] + set main [lindex $doc_elements(main) 0] + if {$main ne ""} { + 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 + } + } + } + if {$haveBlocks} { - append out "

\n" + set blocks_out "
\n" if { [info exists doc_elements(param)] } { foreach param $doc_elements(param) { @@ -483,49 +510,49 @@ } if { [llength $doc_elements(switches)] > 0 } { - append out "
Switches:
\n" + append blocks_out "
Switches:
\n" foreach switch $doc_elements(switches) { - append out "
-$switch" + append blocks_out "
-$switch" if {"boolean" in $flags($switch)} { - append out " (boolean)" + append blocks_out " (boolean)" } if { [info exists default_values($switch)] && $default_values($switch) ne "" } { - append out " (defaults to \"[ns_quotehtml $default_values($switch)]\")" + append blocks_out " (defaults to \"[ns_quotehtml $default_values($switch)]\")" } if {"required" in $flags($switch)} { - append out " (required)" + append blocks_out " (required)" } else { - append out " (optional)" + append blocks_out " (optional)" } - append out "
" + append blocks_out "" if { [info exists params($switch)] } { - append out "
$params($switch)
" + append blocks_out "
$params($switch)
" } } - append out "
\n" + append blocks_out "
\n" } if { [llength $doc_elements(positionals)] > 0 } { - append out "
Parameters:
\n" + append blocks_out "
Parameters:
\n" foreach positional $doc_elements(positionals) { - append out "$positional" + append blocks_out "$positional" if { [info exists default_values($positional)] } { if { $default_values($positional) eq "" } { - append out " (optional)" + append blocks_out " (optional)" } else { - append out " (defaults to \"$default_values($positional)\")" + append blocks_out " (defaults to \"$default_values($positional)\")" } } if { [info exists params($positional)] } { - append out " - $params($positional)" + append blocks_out " - $params($positional)" } - append out "
\n" + append blocks_out "
\n" } - append out "
\n" + append blocks_out "\n" } @@ -535,46 +562,47 @@ # by ad_proc. if { [info exists doc_elements(option)] } { - append out "Options:
" + append blocks_out "Options:
" foreach param $doc_elements(option) { if { [regexp {^([^ \t]+)[ \t](.+)$} $param "" name value] } { - append out "
-$name
$value
" + append blocks_out "
-$name
$value
" } } - append out "
" + append blocks_out "
" } if { [info exists doc_elements(return)] } { - append out "
Returns:
[join $doc_elements(return) "
"]
\n" + append blocks_out "
Returns:
[join $doc_elements(return) "
"]
\n" } if { [info exists doc_elements(error)] } { - append out "
Error:
[join $doc_elements(error) "
"]
\n" + append blocks_out "
Error:
[join $doc_elements(error) "
"]
\n" } - append out [::apidoc::format_common_elements doc_elements] - - append out "
\n" + append blocks_out [::apidoc::format_common_elements doc_elements] + append blocks_out "
\n" + } else { + set blocks_out "" } - - if { $source_p } { if {[parameter::get_from_package_key \ -package_key acs-api-browser \ -parameter FancySourceFormattingP \ -default 1]} { - append out [subst {
Source code:
+ set source_out [subst {
Source code:
[::apidoc::tcl_to_html $proc_name]
}] } else { - append out [subst {
Source code:
+ set source_out [subst {
Source code:
[ns_quotehtml [api_get_body $proc_name]]
}] } + } else { + set source_out "" } set xql_base_name $::acs::rootdir/ @@ -600,9 +628,10 @@ if { [file exists $::acs::rootdir/$xql_fn] } { set content [apidoc::get_xql_snippet -proc_name $proc_name -xql_file $xql_fn] if {$content ne ""} {set content "
$content
"} + set href [export_vars -base content-page-view {{source_p 1} {path $xql_fn}}] append there [subst {
PostgreSQL XQL file:
$content - $xql_fn + $xql_fn

}] @@ -614,29 +643,37 @@ if { [file exists $::acs::rootdir/$xql_fn] } { set content [apidoc::get_xql_snippet -proc_name $proc_name -xql_file $xql_fn] if {$content ne ""} {set content "
$content
"} + set href [export_vars -base content-page-view {{source_p 1} {path $xql_fn}}] append there [subst {
Oracle XQL file:
$content - $xql_fn + $xql_fn

}] } else { lappend missing Oracle } if {[llength $missing] > 0} { - append out [subst {
XQL Not present:
[join $missing ", "]
}] + set xql_out [subst {
XQL Not present:
[join $missing ", "]
}] } - append out $there + append xql_out $there + } else { + set xql_out "" } + set out_sections $intro_out$blocks_out$source_out$xql_out + if {$out_sections ne ""} { + append out
$out_sections
+ } # No "see also" yet. - append out "
" return $out } ad_proc api_proc_pretty_name { -link:boolean + -include_debug_controls:boolean + {-proc_type ""} -label proc } { @@ -648,22 +685,21 @@ set label $proc } if { $link_p } { - append out "$label" + append out [subst {$label}] } else { - append out "$label" + append out $label } - array set doc_elements [nsv_get api_proc_doc $proc] - if {$doc_elements(deprecated_p)} { - set deprecated ", decprecated" - } else { - set deprecated "" + 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 {[llength $hints] > 0} { + append out " ([join $hints {, }])" } - if { $doc_elements(public_p) } { - append out " (public$deprecated)" - } - if { $doc_elements(private_p) } { - append out " (private$deprecated)" - } + append out $debug_html return $out } @@ -716,27 +752,29 @@ ad_proc -public api_get_body {proc_name} { - This function returns the body of a tcl proc or an xotcl method. + 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 prox } { - - if {[regexp {^(.*) (inst)?proc (.*)$} $proc_name match obj prefix method]} { + if {[info commands ::xo::api] ne "" + && [regexp {^(.*) (inst)?proc (.*)$} $proc_name match obj prefix method]} { if {[regexp {^(.*) (.*)$} $obj match thread obj]} { - # the definition is located in a disconnected thread - return [$thread do ::Serializer methodSerialize $obj $method $prefix] + return [::xo::api get_method_source $thread $obj $prefix $method] } else { - # the definition is locally in the connection thread - return [::Serializer methodSerialize $obj $method $prefix] + return [::xo::api get_method_source "" $obj $prefix $method] } - } elseif {[regexp {^([^ ]+)(Class|Object) (.*)$} $proc_name match thread kind obj]} { - return [$thread do $obj serialize] + } 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] ne ""} { return [info body $proc_name] } elseif {[info procs ::nsf::procs::$proc_name] ne ""} { return [::nx::Object info method body ::nsf::procs::$proc_name] } else { - return "No such Tcl-proc" + return "No such Tcl-proc '$proc_name'" } } @@ -764,26 +802,42 @@ } ad_proc -public format_see { see } { - regsub -all {proc *} $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 comtain 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]} { - return "$see" + set href [export_vars -base /api-doc/proc-view {{proc $see}}] + return [subst {$see}] } - if {[string match "/doc/*.html" $see] + if {[string match "/doc/*" $see] || [util_url_valid_p $see]} { - return "$see" + return [subst {$see}] } if {[file exists "$::acs::rootdir${see}"]} { - return "$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 + @return the formatted result + } { if { [regexp {^[^ \n\r\t]+$} $author_string] && [string first "@" $author_string] >= 0 && [string first ":" $author_string] < 0 } { - return "$author_string" + return [subst {$author_string}] } elseif { [regexp {^([^\(\)]+)\s+\((.+)\)$} [string trim $author_string] {} name email] } { return "$name <$email>" } @@ -956,13 +1010,13 @@ return $score } - ad_proc -private is_xotcl_object {scope proc_name} { + ad_proc -private is_object {scope proc_name} { Checks, whether the specified argument is an xotcl object. Does not cause problems when xocl is not loaded. @return boolean value } { set result 0 - catch {set result [::xotcl::api inscope $scope ::xotcl::Object isobject $proc_name]} + catch {set result [::xo::api isobject $scope $proc_name]} return $result } @@ -971,24 +1025,24 @@ 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. -

+

Known Issues: -

    -
  1. This proc will mistakenly highlight switch strings that look like commands as commands, etc. -
  2. There are many undocumented AOLserver commands including all of the commands added by modules. -
  3. When a proc inside a string has explicitly quoted arguments, they are not formatted. -
  4. regexp and regsub are hard to parse properly. E.g. If we use the start option, and we quote its argument, +
      +
    1. This proc will mistakenly highlight switch strings that look like commands as commands, etc. +
    2. There are many undocumented AOLserver commands including all of the commands added by modules. +
    3. When a proc inside a string has explicitly quoted arguments, they are not formatted. +
    4. regexp and regsub are hard to parse properly. E.g. If we use the start option, and we quote its argument, and we have an ugly regexp, then this code might highlight it incorrectly. -
    +
@author Jamie Rasmussen (jrasmuss@mle.ie) @param proc_name procedure to format in HTML } { - if {[info commands ::xotcl::api] ne ""} { - set scope [::xotcl::api scope_from_proc_index $proc_name] + if {[info commands ::xo::api] ne ""} { + set scope [::xo::api scope_from_proc_index $proc_name] } else { set scope "" } @@ -1096,6 +1150,35 @@ 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 } { @@ -1112,14 +1195,16 @@ } { + 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 ::xotcl::api] ne ""} { + 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] .. @@ -1228,6 +1313,59 @@ 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 eq "*" || $proc_name eq "@"} { append html $proc_name } elseif {$proc_name in $::apidoc::KEYWORDS || @@ -1243,13 +1381,6 @@ } elseif {$proc_name in $XOTCL_KEYWORDS} { append html [pretty_token keyword $proc_name] - } elseif {[is_xotcl_object $scope $proc_name]} { - set url [::xotcl::api object_url \ - -show_source 1 -show_methods 2 \ - $scope $proc_name] - append html "" \ - [pretty_token object $proc_name] - } elseif {[string match "ns*" $proc_name]} { set url "/api-doc/tcl-proc-view?tcl_proc=$proc_name" append html "" \ @@ -1260,21 +1391,47 @@ } elseif {$proc_namespace ne "" && [info commands ::${proc_namespace}::${proc_name}] ne ""} { - set url [api_proc_url ${proc_namespace}::${proc_name}] - append html "" \ - [pretty_token proc $proc_name] - - } elseif {[info commands ::$proc_name] ne ""} { - set url [api_proc_url $proc_name] - append html "" \ - [pretty_token proc $proc_name] - + + 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} + 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 @@ -1312,7 +1469,7 @@ ad_proc -private xql_links_list { path } { - Returns list of xql files related to tcl script file + Returns list of xql files related to Tcl script file @param path path and filename from $::acs::rootdir } { @@ -1348,21 +1505,13 @@ @return sanitized path } { - - if {[regsub -all {[.][.]/} $path "" shortened_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 $shortened_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 } @@ -1397,7 +1546,7 @@ @author Lars Pind (lars@pinds.com) @creation-date 14 July 2000 } { - return "$proc" + return "$proc" }