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
"
- foreach see $sees {
- append out "- [api_format_see $see]\n"
- }
- append out "
\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"
- foreach column $columns {
- append out "- $column"
- if { [info exists property_doc($property.$column)] } {
- append out " - $property_doc($property.$column)"
- }
- }
- 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"
+ foreach column $columns {
+ append out "- $column"
+ if { [info exists property_doc($property.$column)] } {
+ append out " - $property_doc($property.$column)"
+ }
+ }
+ 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 "$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 "$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:
-
-- This proc will mistakenly highlight switch strings that look like commands as commands, etc.
-
- There are many undocumented AOLserver commands including all of the commands added by modules.
-
- When a proc inside a string has explicitly quoted arguments, they are not formatted.
-
- 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"
+ foreach see $sees {
+ append out "- [api_format_see $see]\n"
+ }
+ append out "
\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:
+
+ - This proc will mistakenly highlight switch strings that look like commands as commands, etc.
+
- There are many undocumented AOLserver commands including all of the commands added by modules.
+
- When a proc inside a string has explicitly quoted arguments, they are not formatted.
+
- 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: