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.27.8.11 -r1.27.8.12 --- openacs-4/packages/acs-api-browser/tcl/acs-api-documentation-procs.tcl 18 May 2014 10:09:19 -0000 1.27.8.11 +++ openacs-4/packages/acs-api-browser/tcl/acs-api-documentation-procs.tcl 2 Sep 2014 18:04:07 -0000 1.27.8.12 @@ -1,5 +1,3 @@ -# /packages/acs-core/api-documentation-procs.tcl - ad_library { Routines for generating API documentation. @@ -11,29 +9,17 @@ } -ad_proc -private api_first_sentence { string } { - - Returns the first sentence of a string. - -} { - - if { [regexp {^(.+?\.)\s} $string "" sentence] } { - return $sentence - } - return $string -} - 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. + 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. + an empty list if the file does not contain a doc_page_contract + block. @error if the file does not exist. } { @@ -42,121 +28,44 @@ set has_contract_p 0 if { ![file exists "$::acs::rootdir/$path"] } { - return -code error "File $path does not exist" + return -code 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_contract\s} $line] - break - } + # Eliminate any comment characters. + regsub -all {\#.*$} $line "" line + set line [string trim $line] + if { $line ne "" } { + set has_contract_p [regexp {^ad_page_contract\s} $line] + break + } } close $file if { !$has_contract_p } { - return [list] + return [list] } doc_set_page_documentation_mode 1 set errno [catch { source "$::acs::rootdir/$path" } error] doc_set_page_documentation_mode 0 if { $errno == 1 } { - global errorInfo - if { [regexp {^ad_page_contract documentation} $errorInfo] } { - array set doc_elements $error - } + if { [regexp {^ad_page_contract documentation} $::errorInfo] } { + array set doc_elements $error + } } else { - global errorCode - global errorInfo - return -code $errno -errorcode $errorCode -errorinfo $errorInfo $error - } + global errorCode + global errorInfo + return -code $errno -errorcode $errorCode -errorinfo $errorInfo $error + } if { [info exists doc_elements] } { - return [array get doc_elements] + return [array get doc_elements] } return [list] } - -ad_proc -private api_format_see_list { sees } { - Generate an HTML list of referenced procs and pages. -} { - append out "
See Also:\n\n" - - return $out -} - -ad_proc -private api_format_author_list { authors } { - Generates an HTML-formatted list of authors (including <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 "
Author[ad_decode [llength $authors] 1 "" "s"]:\n" - foreach author $authors { - append out "
[api_format_author $author]
\n" - } - return $out -} - - -ad_proc -private api_format_changelog_change { change } { - Formats the change log line: turns email addresses in parenthesis into links. -} { - regsub {\(([^ \n\r\t]+@[^ \n\r\t]+\.[^ \n\r\t]+)\)} $change {(\1)} change - return $change -} - -ad_proc -private api_format_changelog_list { changelog } { - Format the change log info -} { - append out "
Changelog:\n" - foreach change $changelog { - append out "
[api_format_changelog_change $change]
\n" - } - return $out -} - - -ad_proc -private api_format_common_elements { doc_elements_var } { - upvar $doc_elements_var doc_elements - - set out "" - - if { [info exists doc_elements(author)] } { - append out [api_format_author_list $doc_elements(author)] - } - if { [info exists doc_elements(creation-date)] } { - append out "
Created:\n
[lindex $doc_elements(creation-date) 0]
\n" - } - if { [info exists doc_elements(change-log)] } { - append out [api_format_changelog_list $doc_elements(change-log)] - } - if { [info exists doc_elements(cvs-id)] } { - append out "
CVS ID:\n
[ns_quotehtml [lindex $doc_elements(cvs-id) 0]]
\n" - } - if { [info exists doc_elements(see)] } { - append out [api_format_see_list $doc_elements(see)] - } - - return $out -} - - - ad_proc -public api_script_documentation { { -format text/html } path @@ -166,9 +75,9 @@ to obtain the comment or contract at the beginning. @param format the type of documentation to generate. Currently, only - text/html is supported. + text/html is supported. @param path the path of the Tcl file to examine, relative to the - OpenACS root directory. + OpenACS root directory. @return the formatted documentation string. @error if the file does not exist. @@ -178,142 +87,115 @@ # If it's not a Tcl file, we can't do a heck of a lot yet. Eventually # we'll be able to handle ADPs, at least. if {[file extension $path] eq ".xql"} { - append out "
DB Query file
\n" - return $out + append out "
DB Query file
\n" + return $out } elseif { [file extension $path] ne ".tcl" } { - append out "
Delivered as [ns_guesstype $path]
\n" - return $out + append out "
Delivered as [ns_guesstype $path]
\n" + return $out } if { [catch { array set doc_elements [api_read_script_documentation $path] } error] } { - append out "
Unable to read $path: [ns_quotehtml $error]
\n" - return $out + append out "
Unable to read $path: [ns_quotehtml $error]
\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 - } - } + foreach param $doc_elements(param) { + if { [regexp {^([^ \t]+)[ \t](.+)$} $param "" name value] } { + set params($name) $value + } + } } - + append out "
" if { [info exists doc_elements(main)] } { - append out [lindex $doc_elements(main) 0] + append out [lindex $doc_elements(main) 0] } else { - append out "Does not contain a contract." + 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 { [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 \"$as_default_value($arg_name)\"" -# } -# set notes [concat $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 "
\n" -# } -# if { [info exists doc_elements(type)] && $doc_elements(type) ne "" } { -# append out "
Returns Type:
$doc_elements(type)\n" -# } -# # XXX: Need to support "Returns Properties:" -# } + # 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 \"$as_default_value($arg_name)\"" + # } + # set notes [concat $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 "
\n" + # } + # if { [info exists doc_elements(type)] && $doc_elements(type) ne "" } { + # append out "
Returns Type:
$doc_elements(type)\n" + # } + # # XXX: Need to support "Returns Properties:" + # } append out "
Location:
$path\n" - append out [api_format_common_elements doc_elements] + append out [::apidoc::api_format_common_elements doc_elements] append out "
" return $out } -ad_proc -private api_format_author { author_string } { - if { [regexp {^[^ \n\r\t]+$} $author_string] - && [string first "@" $author_string] >= 0 - && [string first ":" $author_string] < 0 } { - return "$author_string" - } elseif { [regexp {^([^\(\)]+)\s+\((.+)\)$} [string trim $author_string] {} name email] } { - return "$name <$email>" - } - return $author_string -} - -ad_proc -private api_format_see { see } { - regsub -all {proc *} $see {} see - set see [string trim $see] - if {[nsv_exists api_proc_doc $see]} { - return "$see" - } - if {[string match "/doc/*.html" $see] - || [util_url_valid_p $see]} { - return "$see" - } - if {[file exists "$::acs::rootdir${see}"]} { - return "$see" - } - return ${see} -} - 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). + 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" + return -code error "Only text/html documentation is currently supported" } set out "

[file tail $path]

" if { [nsv_exists api_library_doc $path] } { - array set doc_elements [nsv_get api_library_doc $path] - append out "
\n" - append out [lindex $doc_elements(main) 0] + array set doc_elements [nsv_get api_library_doc $path] + append out "
\n" + append out [lindex $doc_elements(main) 0] - append out "
\n" - append out "
Location:\n
$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[ad_decode [llength $doc_elements(author)] 1 "" "s"]:\n" - foreach author $doc_elements(author) { - append out "
[api_format_author $author]\n" - } - } - if { [info exists doc_elements(cvs-id)] } { - append out "
CVS Identification:\n
[ns_quotehtml [lindex $doc_elements(cvs-id) 0]]\n" - } - append out "
\n" - append out "
\n" + append out "
\n" + append out "
Location:\n
$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[ad_decode [llength $doc_elements(author)] 1 "" "s"]:\n" + foreach author $doc_elements(author) { + append out "
[::apidoc::api_format_author $author]\n" + } + } + if { [info exists doc_elements(cvs-id)] } { + append out "
CVS Identification:\n
[ns_quotehtml [lindex $doc_elements(cvs-id) 0]]\n" + } + append out "
\n" + append out "
\n" } return $out @@ -338,72 +220,46 @@ 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 $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" - } + 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" + } } - append out [api_format_common_elements doc_elements] + append out \ + [::apidoc::api_format_common_elements doc_elements] \ + "
Location:
$doc_elements(script)\n" \ + "\n" - append out "
Location:
$doc_elements(script)\n" - - append out "\n" - return $out } -ad_proc -private api_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 -public api_quote_file { filename } { @@ -419,266 +275,266 @@ ad_proc -public api_proc_documentation { - {-format text/html} - -script:boolean - -source:boolean - -xql:boolean - -label - {-first_line_tag

} - proc_name + {-format text/html} + -script:boolean + -source:boolean + -xql:boolean + -label + {-first_line_tag

} + proc_name } { - Generates formatted documentation for a procedure. + Generates formatted documentation for a procedure. - @param format the type of documentation to generate. Currently, only - text/html and text/plain are supported. - @param script include information about what script this proc lives in? - @param xql include the source code for the related xql files? - @param source include the source code for the script? - @param proc_name the name of the procedure for which to generate documentation. - @param label the label printed for the proc in the header line - @param first_line_tag tag for the markup of the first line - @return the formatted documentation string. - @error if the procedure is not defined. + @param format the type of documentation to generate. Currently, only + text/html and text/plain are supported. + @param script include information about what script this proc lives in? + @param xql include the source code for the related xql files? + @param source include the source code for the script? + @param proc_name the name of the procedure for which to generate documentation. + @param label the label printed for the proc in the header line + @param first_line_tag tag for the markup of the first line + @return the formatted documentation string. + @error if the procedure is not defined. } { - 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 [nsv_get api_proc_doc $proc_name] - array set flags $doc_elements(flags) - array set default_values $doc_elements(default_values) + 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 [nsv_get api_proc_doc $proc_name] + array set flags $doc_elements(flags) + array set default_values $doc_elements(default_values) - if {![info exists label]} { - set label $proc_name + if {![info exists label]} { + set label $proc_name + } + if { $script_p } { + set pretty_name [api_proc_pretty_name -label $label $proc_name] + } else { + set pretty_name [api_proc_pretty_name -link -label $label $proc_name] + } + if {[regexp {<([^ >]+)} $first_line_tag match tag]} { + set end_tag "" + } else { + set first_line_tag "

" + set end_tag "

" + } + append out $first_line_tag$pretty_name$end_tag + + if {[regexp {^(.*) (inst)?proc (.*)$} $proc_name match cl prefix method]} { + set xotcl 1 + set scope "" + if {[regexp {^(.+) (.+)$} $cl match scope cl]} { + set cl "$scope do $cl" } - if { $script_p } { - set pretty_name [api_proc_pretty_name -label $label $proc_name] - } else { - set pretty_name [api_proc_pretty_name -link -label $label $proc_name] - } - if {[regexp {<([^ >]+)} $first_line_tag match tag]} { - set end_tag "" - } else { - set first_line_tag "

" - set end_tag "

" - } - append out $first_line_tag$pretty_name$end_tag - - if {[regexp {^(.*) (inst)?proc (.*)$} $proc_name match cl prefix method]} { - set xotcl 1 - set scope "" - if {[regexp {^(.+) (.+)$} $cl match scope cl]} { - set cl "$scope do $cl" - } - if {$prefix eq ""} { - set pretty_proc_name "[::xotcl::api object_link $scope $cl] $method" - } else { - set pretty_proc_name \ - "<instance of\ - [::xotcl::api object_link $scope $cl]> $method" - } - } else { - set xotcl 0 - set pretty_proc_name $proc_name - } + if {$prefix eq ""} { + set pretty_proc_name "[::xotcl::api object_link $scope $cl] $method" + } else { + set pretty_proc_name \ + "<instance of\ + [::xotcl::api object_link $scope $cl]> $method" + } + } else { + set xotcl 0 + set pretty_proc_name $proc_name + } - lappend command_line $pretty_proc_name - foreach switch $doc_elements(switches) { - if {$xotcl} { - if {"boolean" in $flags($switch)} { - set value "on|off " - } elseif {"switch" in $flags($switch)} { - set value "" - } else { - set value "$switch " - } - if {"required" in $flags($switch)} { - lappend command_line "-$switch $value" - } else { - lappend command_line "\[ -$switch $value\]" - } - } else { - if {"boolean" in $flags($switch)} { - lappend command_line "\[ -$switch \]" - } elseif {"required" in $flags($switch)} { - lappend command_line "-$switch $switch" - } else { - lappend command_line "\[ -$switch $switch \]" - } - } - } - - set counter 0 - foreach positional $doc_elements(positionals) { - if { [info exists default_values($positional)] } { - lappend command_line "\[ $positional \]" - } else { - lappend command_line "$positional" - } - } - if { $doc_elements(varargs_p) } { - lappend command_line "\[ args... \]" - } - append out "[util_wrap_list $command_line]\n
\n" - - if { $script_p } { - append out [subst {Defined in - $doc_elements(script) -

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

\n" - } + lappend command_line $pretty_proc_name + foreach switch $doc_elements(switches) { + if {$xotcl} { + if {"boolean" in $flags($switch)} { + set value "on|off " + } elseif {"switch" in $flags($switch)} { + set value "" + } else { + set value "$switch " + } + if {"required" in $flags($switch)} { + lappend command_line "-$switch $value" + } else { + lappend command_line "\[ -$switch $value\]" + } + } else { + if {"boolean" in $flags($switch)} { + lappend command_line "\[ -$switch \]" + } elseif {"required" in $flags($switch)} { + lappend command_line "-$switch $switch" + } else { + lappend command_line "\[ -$switch $switch \]" + } + } + } + + set counter 0 + foreach positional $doc_elements(positionals) { + if { [info exists default_values($positional)] } { + lappend command_line "\[ $positional \]" + } else { + lappend command_line "$positional" + } + } + if { $doc_elements(varargs_p) } { + lappend command_line "\[ args... \]" + } + append out "[util_wrap_list $command_line]\n

\n" + + if { $script_p } { + append out [subst {Defined in + $doc_elements(script) +

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

\n" + } - append out "[lindex $doc_elements(main) 0] - + append out "[lindex $doc_elements(main) 0] +

" - 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 doc_elements(param)] } { + foreach param $doc_elements(param) { + if { [regexp {^([^ \t\n]+)[ \t\n]+(.*)$} $param "" name value] } { + set params($name) $value + } + } + } + + if { [llength $doc_elements(switches)] > 0 } { + append out "
Switches:
\n" + foreach switch $doc_elements(switches) { + append out "
-$switch" + if {"boolean" in $flags($switch)} { + append out " (boolean)" + } + + if { [info exists default_values($switch)] + && $default_values($switch) ne "" + } { + append out " (defaults to \"[ns_quotehtml $default_values($switch)]\")" + } + + if {"required" in $flags($switch)} { + append out " (required)" + } else { + append out " (optional)" + } + append out "
" + if { [info exists params($switch)] } { + append out "
$params($switch)
" + } + } + append out "
\n" + } + + if { [llength $doc_elements(positionals)] > 0 } { + append out "
Parameters:
\n" + foreach positional $doc_elements(positionals) { + append out "$positional" + if { [info exists default_values($positional)] } { + if { $default_values($positional) eq "" } { + append out " (optional)" + } else { + append out " (defaults to \"$default_values($positional)\")" } } - } - - if { [llength $doc_elements(switches)] > 0 } { - append out "
Switches:
\n" - foreach switch $doc_elements(switches) { - append out "
-$switch" - if {"boolean" in $flags($switch)} { - append out " (boolean)" - } - - if { [info exists default_values($switch)] - && $default_values($switch) ne "" - } { - append out " (defaults to \"$default_values($switch)\")" - } - - if {"required" in $flags($switch)} { - append out " (required)" - } else { - append out " (optional)" - } - append out "
" - if { [info exists params($switch)] } { - append out "
$params($switch)
" - } - } - append out "
\n" - } - - if { [llength $doc_elements(positionals)] > 0 } { - append out "
Parameters:
\n" - foreach positional $doc_elements(positionals) { - append out "$positional" - if { [info exists default_values($positional)] } { - if { $default_values($positional) eq "" } { - append out " (optional)" - } else { - append out " (defaults to \"$default_values($positional)\")" - } - } - if { [info exists params($positional)] } { - append out " - $params($positional)" - } - append out "
\n" - } - append out "
\n" - } - + if { [info exists params($positional)] } { + append out " - $params($positional)" + } + append out "
\n" + } + append 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 out "Options:
" - foreach param $doc_elements(option) { - if { [regexp {^([^ \t]+)[ \t](.+)$} $param "" name value] } { - append out "
-$name
$value
" - } - } - append out "
" - } - + if { [info exists doc_elements(option)] } { + append out "Options:
" + foreach param $doc_elements(option) { + if { [regexp {^([^ \t]+)[ \t](.+)$} $param "" name value] } { + append out "
-$name
$value
" + } + } + append out "
" + } + - if { [info exists doc_elements(return)] } { - append out "
Returns:
[join $doc_elements(return) "
"]
\n" - } - - if { [info exists doc_elements(error)] } { - append out "
Error:
[join $doc_elements(error) "
"]
\n" - } - - append out [api_format_common_elements doc_elements] - - if { $source_p } { - if {[parameter::get_from_package_key \ - -package_key acs-api-browser \ - -parameter FancySourceFormattingP \ - -default 1]} { - append out [subst {
Source code:
-
[api_tcl_to_html $proc_name]
-

-}] - } else { - append out [subst {

Source code:
-
[ns_quotehtml [api_get_body $proc_name]]
-

-}] - } + if { [info exists doc_elements(return)] } { + append out "

Returns:
[join $doc_elements(return) "
"]
\n" + } + + if { [info exists doc_elements(error)] } { + append out "
Error:
[join $doc_elements(error) "
"]
\n" + } + + append out [::apidoc::api_format_common_elements doc_elements] + + if { $source_p } { + if {[parameter::get_from_package_key \ + -package_key acs-api-browser \ + -parameter FancySourceFormattingP \ + -default 1]} { + append out [subst {
Source code:
+ 
[::apidoc::api_tcl_to_html $proc_name]
+

+ }] + } else { + append out [subst {

Source code:
+ 
[ns_quotehtml [api_get_body $proc_name]]
+

+ }] } + } - set xql_base_name $::acs::rootdir/ - append xql_base_name [file rootname $doc_elements(script)] - if { $xql_p } { - set there {} - set missing {} - if { [file exists ${xql_base_name}.xql] } { - append there [subst {

Generic XQL file:
-
[api_quote_file ${xql_base_name}.xql]
-

-}] - } else { - lappend missing Generic - } - if { [file exists ${xql_base_name}-postgresql.xql] } { - append there [subst {

Postgresql XQL file:
-
[api_quote_file ${xql_base_name}-postgresql.xql]
-

-}] - } else { - lappend missing PostgreSQL - } - if { [file exists ${xql_base_name}-oracle.xql] } { - append there [subst {

Oracle XQL file:
-
[api_quote_file ${xql_base_name}-oracle.xql]
-

-}] - } else { - lappend missing Oracle - } - if {[llength $missing] > 0} { - append out [subst {

XQL Not present:
[join $missing ", "]
}] - } - append out $there - } + set xql_base_name $::acs::rootdir/ + append xql_base_name [file rootname $doc_elements(script)] + if { $xql_p } { + set there {} + set missing {} + if { [file exists ${xql_base_name}.xql] } { + append there [subst {
Generic XQL file:
+ 
[api_quote_file ${xql_base_name}.xql]
+

+ }] + } else { + lappend missing Generic + } + if { [file exists ${xql_base_name}-postgresql.xql] } { + append there [subst {

Postgresql XQL file:
+ 
[api_quote_file ${xql_base_name}-postgresql.xql]
+

+ }] + } else { + lappend missing PostgreSQL + } + if { [file exists ${xql_base_name}-oracle.xql] } { + append there [subst {

Oracle XQL file:
+ 
[api_quote_file ${xql_base_name}-oracle.xql]
+

+ }] + } else { + lappend missing Oracle + } + if {[llength $missing] > 0} { + append out [subst {

XQL Not present:
[join $missing ", "]
}] + } + append out $there + } - # No "see also" yet. - - append out "" - - return $out + # No "see also" yet. + + append out "" + + return $out } ad_proc api_proc_pretty_name { @@ -687,88 +543,32 @@ 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 + @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 { $link_p } { - append out "$label" - } else { - append out "$label" + append out "$label" + } else { + append out "$label" } array set doc_elements [nsv_get api_proc_doc $proc] if {$doc_elements(deprecated_p)} { - set deprecated ", decprecated" + set deprecated ", decprecated" } else { - set deprecated "" + set deprecated "" } if { $doc_elements(public_p) } { - append out " (public$deprecated)" + append out " (public$deprecated)" } if { $doc_elements(private_p) } { - append out " (private$deprecated)" + append out " (private$deprecated)" } return $out } -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] == [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} { - returns number of keywords found in string to search. - No additional score for repeats -} { - # turn keywords into space-separated things - # replace one or more commads 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 -public api_apropos_functions { string } { Returns the functions in the system that contain string in their name and have been defined using ad_proc. @@ -816,87 +616,274 @@ return $matches } -ad_proc -private api_is_xotcl_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 - if {[string match "::*" $proc_name]} { ;# only check for absolute names - catch {set result [::xotcl::api inscope $scope ::xotcl::Object isobject $proc_name]} - } - return $result -} 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 prox + 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 {[regexp {^(.*) (.*)$} $obj match thread obj]} { - # the definition is located in a disconnected thread - return [$thread do ::Serializer methodSerialize $obj $method $prefix] + if {[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] + } else { + # the definition is locally in the connection thread + return [::Serializer methodSerialize $obj $method $prefix] + } + } elseif {[regexp {^([^ ]+)(Class|Object) (.*)$} $proc_name match thread kind obj]} { + return [$thread do $obj serialize] + } 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 { - # the definition is locally in the connection thread - return [::Serializer methodSerialize $obj $method $prefix] + return "No such Tcl-proc" } - } elseif {[regexp {^([^ ]+)(Class|Object) (.*)$} $proc_name match thread kind obj]} { - return [$thread do $obj serialize] - } 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" - } } -ad_proc -private api_tcl_to_html {proc_name} { +namespace eval ::apidoc { - 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, - and we have an ugly regexp, then this code might highlight it incorrectly. -
+ ad_proc -private api_format_see { see } { + regsub -all {proc *} $see {} see + set see [string trim $see] + if {[nsv_exists api_proc_doc $see]} { + return "$see" + } + if {[string match "/doc/*.html" $see] + || [util_url_valid_p $see]} { + return "$see" + } + if {[file exists "$::acs::rootdir${see}"]} { + return "$see" + } + return ${see} + } - @author Jamie Rasmussen (jrasmuss@mle.ie) + ad_proc -private api_format_author { author_string } { + if { [regexp {^[^ \n\r\t]+$} $author_string] + && [string first "@" $author_string] >= 0 + && [string first ":" $author_string] < 0 } { + return "$author_string" + } elseif { [regexp {^([^\(\)]+)\s+\((.+)\)$} [string trim $author_string] {} name email] } { + return "$name <$email>" + } + return $author_string + } - @param proc_name procedure to format in HTML + ad_proc -private api_format_changelog_list { changelog } { + Format the change log info + } { + append out "
Changelog:\n" + foreach change $changelog { + append out "
[api_format_changelog_change $change]
\n" + } + return $out + } -} { + ad_proc -private api_format_changelog_change { change } { + Formats the change log line: turns email addresses in parenthesis into links. + } { + regsub {\(([^ \n\r\t]+@[^ \n\r\t]+\.[^ \n\r\t]+)\)} $change {(\1)} change + return $change + } - if {[info commands ::xotcl::api] ne ""} { - set scope [::xotcl::api scope_from_proc_index $proc_name] - } else { - set scope "" + ad_proc -private api_format_author_list { authors } { + + Generates an HTML-formatted list of authors + (including <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 "
Author[ad_decode [llength $authors] 1 "" "s"]:\n" + foreach author $authors { + append out "
[api_format_author $author]
\n" + } + return $out } - set proc_namespace "" - regexp {^(::)?(.*)::[^:]+$} $proc_name match colons proc_namespace + ad_proc -private api_format_common_elements { doc_elements_var } { + upvar $doc_elements_var doc_elements - return [api_tclcode_to_html -scope $scope -proc_namespace $proc_namespace [api_get_body $proc_name]] -} + set out "" -ad_proc -private api_tclcode_to_html {{-scope ""} {-proc_namespace ""} script} { + if { [info exists doc_elements(author)] } { + append out [api_format_author_list $doc_elements(author)] + } + if { [info exists doc_elements(creation-date)] } { + append out "
Created:\n
[lindex $doc_elements(creation-date) 0]
\n" + } + if { [info exists doc_elements(change-log)] } { + append out [api_format_changelog_list $doc_elements(change-log)] + } + if { [info exists doc_elements(cvs-id)] } { + append out "
CVS ID:\n
[ns_quotehtml [lindex $doc_elements(cvs-id) 0]]
\n" + } + if { [info exists doc_elements(see)] } { + append out [api_format_see_list $doc_elements(see)] + } - 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. + return $out + } - @param script script to be formated in HTML + ad_proc -private api_format_see_list { sees } { + Generate an HTML list of referenced procs and pages. + } { + append out "
See Also:\n\n" + + return $out + } -} { + ad_proc -private api_first_sentence { string } { + Returns the first sentence of a string. + + } { + if { [regexp {^(.+?\.)\s} $string "" sentence] } { + return $sentence + } + return $string + } + + ad_proc -private api_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} { + returns number of keywords found in string to search. + No additional score for repeats + } { + # turn keywords into space-separated things + # replace one or more commads 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 api_is_xotcl_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 + if {[string match "::*" $proc_name]} { ;# only check for absolute names + catch {set result [::xotcl::api inscope $scope ::xotcl::Object isobject $proc_name]} + } + return $result + } + + ad_proc -private api_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. +

+ 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, + 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] + } else { + set scope "" + } + + set proc_namespace "" + regexp {^(::)?(.*)::[^:]+$} $proc_name match colons proc_namespace + + return [api_tclcode_to_html -scope $scope -proc_namespace $proc_namespace [api_get_body $proc_name]] + } + + # Returns length of a variable name proc length_var {data} { if {[regexp -indices {^\$\{[^\}]+\}} $data found]} { @@ -907,6 +894,7 @@ return 0 } + # Returns length of a command name proc length_proc {data} { if {[regexp -indices {^(::)?[A-Za-z][:A-Za-z0-9_@]+} $data found]} { @@ -975,10 +963,10 @@ incr i [length_exp [string range $data $i end]] set curchar [string index $data $i] } - return [expr {$i -1}] + return [expr {$i - 1}] } - array set HTML { + set HTML { comment {} /comment {} procs {} @@ -987,193 +975,226 @@ /str {} var {} /var {} - object {} - /object {} + object {} + /object {} } - # 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 + set KEYWORDS { + if while foreach for switch default + after break continue return error catch + upvar uplevel eval exec source variable namespace package load + set unset trace append global vwait split join + concat list lappend lset lindex linsert llength lrange lreplace lsearch lsort + info incr expr regexp regsub binary + string array open close read cd pwd glob seek pid + file fblocked fcopy fconfigure fileevent filename flush eof + clock encoding proc rename subst update + gets puts socket tell format scan + } - set KEYWORDS [concat \ - {if while foreach for switch default} \ - {after break continue return error catch} \ - {upvar uplevel eval exec source variable namespace package load} \ - {set unset trace append global vwait split join} \ - {concat list lappend lset lindex linsert llength lrange lreplace lsearch lsort} \ - {info incr expr regexp regsub binary} \ - {string array open close read cd pwd glob seek pid} \ - {file fblocked fcopy fconfigure fileevent filename flush eof} \ - {clock encoding proc rename subst update} \ - {gets puts socket tell format scan} \ - ] - if {[info commands ::xotcl::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 {} - } + ad_proc -private api_tclcode_to_html {{-scope ""} {-proc_namespace ""} script} { - # Returns a list of the commands from all namespaces. - proc list_all_procs {{parentns ::}} { - set result [info commands ${parentns}::*] - foreach ns [namespace children $parentns] { - set result [concat $result [list_all_procs $ns]] - } - return $result - } - set COMMANDS [list_all_procs] + 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. - set data [string map [list & "&" < "<" > ">"] \n$script] + @param script script to be formated in HTML - 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] - } - } + # 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 {$in_comment || [string index $data $i+1] eq " "} { - append html "\$" - } else { - set varl [length_var [string range $data $i end]] - append html "$HTML(var)[string range $data $i $i+$varl]$HTML(/var)" - incr i $varl - } + if {[info commands ::xotcl::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 {} } - "\"" { - if {$in_comment} { - append html "\"" - } elseif {$in_quotes} { - append html \"$HTML(/str) - set in_quotes 0 - } else { - append html $HTML(str)\" - set in_quotes 1 - set proc_ok 0 - } - } + set data [string map [list & "&" < "<" > ">"] \n$script] - "\#" { - 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 $HTML(comment) - } - append html "#" - } + 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 { - "\n" { - set proc_ok 1 - if {$in_quotes} { - set proc_ok 0 - } - if {$in_comment} { - append html $HTML(/comment) - } - append html "\n" - set in_comment 0 - } + "\\" { + 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_quotes} { - set proc_ok 1 - } - append html $char - } + "\$" { + if {$in_comment || [string index $data $i+1] eq " "} { + append html "\$" + } else { + set varl [length_var [string range $data $i end]] + append html "[dict get $::apidoc::HTML var][string range $data $i $i+$varl][dict get $::apidoc::HTML /var]" + incr i $varl + } + } - "\}" { - 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}$HTML(procs)${els}$HTML(/procs)${post}" - set proc_ok 1 - incr i [expr {[string length $pre] + [string length $els] + [string length $post]}] - } - } + "\"" { + if {$in_comment} { + append html "\"" + } elseif {$in_quotes} { + append html \"[dict get $::apidoc::HTML /str] + set in_quotes 0 + } else { + append html [dict get $::apidoc::HTML str]\" + set in_quotes 1 + set proc_ok 0 + } + } - "\[" { - if {!$in_comment} { - set proc_ok 1 - } - append html "\[" - } + "\#" { + 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 [dict get $::apidoc::HTML comment] + } + 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] + "\n" { + set proc_ok 1 + if {$in_quotes} { + set proc_ok 0 + } + if {$in_comment} { + append html [dict get $::apidoc::HTML /comment] + } + append html "\n" + set in_comment 0 + } - if {$proc_name in $KEYWORDS || - ([regexp {^::(.*)} $proc_name match had_colons] && - $had_colons in $KEYWORDS)} { - append html "$HTML(procs)${proc_name}$HTML(/procs)" - } elseif {$proc_name in $XOTCL_KEYWORDS} { - append html "$HTML(procs)${proc_name}$HTML(/procs)" - } elseif {[api_is_xotcl_object $scope $proc_name]} { - set url [::xotcl::api object_url \ - -show_source 1 -show_methods 2 \ - $scope $proc_name] - append html "$HTML(object)${proc_name}$HTML(/object)" - } elseif {[string match "ns*" $proc_name]} { - set url "/api-doc/tcl-proc-view?tcl_proc=$proc_name" - append html "$HTML(procs)${proc_name}$HTML(/procs)" - } elseif {[string match "*__arg_parser" $proc_name]} { - append html "$HTML(procs)${proc_name}$HTML(/procs)" - } elseif {"::${proc_namespace}::${proc_name}" in $COMMANDS} { - set url [api_proc_url ${proc_namespace}::${proc_name}] - append html "$HTML(procs)${proc_name}$HTML(/procs)" - } elseif {"::$proc_name" in $COMMANDS} { - set url [api_proc_url $proc_name] - append html "$HTML(procs)${proc_name}$HTML(/procs)" - } else { - append html ${proc_name} - set proc_ok 1 + "\{" - + ";" { + if {!$in_quotes} { + set proc_ok 1 + } + append html $char } - incr i $procl - # Hack for nasty regexp stuff - if {"regexp" eq $proc_name || "regsub" eq $proc_name} { - set regexpl [length_regexp [string range $data $i end]] - append html [string range $data $i+1 $i+$regexpl] - incr i $regexpl + "\}" { + 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}[dict get $::apidoc::HTML procs]${els}[dict get $::apidoc::HTML /procs]${post}" + set proc_ok 1 + incr i [expr {[string length $pre] + [string length $els] + [string length $post]}] + } } - } else { - append html $char - set proc_ok 0 + + "\[" { + 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 in $::apidoc::KEYWORDS || + ([regexp {^::(.*)} $proc_name match had_colons] && + $had_colons in $::apidoc::KEYWORDS)} { + append html "[dict get $::apidoc::HTML procs]${proc_name}[dict get $::apidoc::HTML /procs]" + } elseif {$proc_name in $XOTCL_KEYWORDS} { + append html "[dict get $::apidoc::HTML procs]${proc_name}[dict get $::apidoc::HTML /procs]" + } elseif {[api_is_xotcl_object $scope $proc_name]} { + set url [::xotcl::api object_url \ + -show_source 1 -show_methods 2 \ + $scope $proc_name] + append html "[dict get $::apidoc::HTML object]${proc_name}[dict get $::apidoc::HTML /object]" + } elseif {[string match "ns*" $proc_name]} { + set url "/api-doc/tcl-proc-view?tcl_proc=$proc_name" + append html "[dict get $::apidoc::HTML procs]${proc_name}[dict get $::apidoc::HTML /procs]" + } elseif {[string match "*__arg_parser" $proc_name]} { + append html "[dict get $::apidoc::HTML procs]${proc_name}[dict get $::apidoc::HTML /procs]" + } elseif {[info commands ::${proc_namespace}::${proc_name}] ne ""} { + set url [api_proc_url ${proc_namespace}::${proc_name}] + append html "[dict get $::apidoc::HTML procs]${proc_name}[dict get $::apidoc::HTML /procs]" + } elseif {[info commands ::$proc_name] ne ""} { + set url [api_proc_url $proc_name] + append html "[dict get $::apidoc::HTML procs]${proc_name}[dict get $::apidoc::HTML /procs]" + } else { + append html ${proc_name} + set proc_ok 1 + } + incr i $procl + + # Hack for nasty regexp stuff + if {"regexp" eq $proc_name || "regsub" eq $proc_name} { + set regexpl [length_regexp [string range $data $i end]] + append html [string range $data $i+1 $i+$regexpl] + incr i $regexpl + } + } else { + append html $char + set proc_ok 0 + } + } } } - } + + # We added a linefeed at the beginning to simplify processing + return [string range $html 1 end] } - # We added a linefeed at the beginning to simplify processing - return [string range $html 1 end] + ad_proc -private api_xql_links_list { path } { + + Returns list of xql files related to tcl script file + @param path path and filename from $::acs::rootdir + + + } { + + set linkList [list] + 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 + set files \ + [lsort -decreasing \ + [glob -nocomplain \ + -directory $file_dirname \ + "${file_rootname}{,-}{,oracle,postgresql}.{adp,tcl,xql}" ]] + + foreach file $files { + lappend linkList [list \ + filename $file \ + link "content-page-view?source_p=1&path=[ns_urlencode "$path_dirname/[file tail $file]"]" \ + ] + + } + + return $linkList + } } @@ -1206,34 +1227,11 @@ return "$proc" } -ad_proc -private api_xql_links_list { path } { - - Returns list of xql files related to tcl script file - @param path path and filename from $::acs::rootdir - - -} { - - set linkList [list] - 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 - set files \ - [lsort -decreasing \ - [glob -nocomplain \ - -directory $file_dirname \ - "${file_rootname}{,-}{,oracle,postgresql}.{adp,tcl,xql}" ]] - - foreach file $files { - lappend linkList [list \ - filename $file \ - link "content-page-view?source_p=1&path=[ns_urlencode "$path_dirname/[file tail $file]"]" \ - ] - - } - return $linkList - -} + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 4 +# indent-tabs-mode: nil +# End: