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.72.2.25 -r1.72.2.26
--- openacs-4/packages/acs-api-browser/tcl/acs-api-documentation-procs.tcl 1 Feb 2021 10:57:30 -0000 1.72.2.25
+++ openacs-4/packages/acs-api-browser/tcl/acs-api-documentation-procs.tcl 19 Feb 2021 10:08:49 -0000 1.72.2.26
@@ -737,8 +737,8 @@
append out $label
}
set debug_html [expr {$include_debug_controls_p
- && [namespace which ::xo::api] ne ""
- ? [::xo::api debug_widget $proc] : ""}]
+ && [namespace which ::xo::api] ne ""
+ ? [::xo::api debug_widget $proc] : ""}]
}
if {[nsv_exists api_proc_doc $proc]} {
set doc_elements [nsv_get api_proc_doc $proc]
@@ -1177,6 +1177,17 @@
namespace eval ::apidoc {
+ ad_proc -private get_doc_property {proc_name property {default ""}} {
+ Return a certain doc property valie, if property exists
+ } {
+ if {[nsv_get api_proc_doc $proc_name doc]} {
+ if {[dict exists $doc $property]} {
+ return [dict get $doc $property]
+ }
+ }
+ return $default
+ }
+
ad_proc -private get_xql_snippet {-proc_name -xql_file} {
@return matching xql snippet for specified proc_name
} {
@@ -1788,8 +1799,16 @@
}
}
}
- if {$proc_name in {* @ ?}} {
+ #
+ # The last three words in the following clause
+ # are deprecated procs which are unfortunatley
+ # picked up as commands by
+ # apidoc::tclcode_to_html. Therefore, we
+ # ignore these explicitly.
+ #
+ if {$proc_name in {* @ ? min max random}} {
append html $proc_name
+
} elseif {$proc_name in $::apidoc::KEYWORDS ||
([regexp {^::(.*)} $proc_name match had_colons]
&& $had_colons in $::apidoc::KEYWORDS)} {
@@ -1811,9 +1830,8 @@
} elseif {[string match "*__arg_parser" $proc_name]} {
append html [pretty_token helper $proc_name]
- } elseif {$proc_namespace ne "" && [
- namespace which ::${proc_namespace}::${proc_name}]
- ne ""} {
+ } elseif {$proc_namespace ne ""
+ && [namespace which ::${proc_namespace}::${proc_name}] ne ""} {
if {[is_object $scope ${proc_namespace}::${proc_name}]} {
set url [::xo::api object_url \
@@ -1827,10 +1845,10 @@
[pretty_token proc $proc_name]
}
} elseif {[namespace which ::$proc_name] ne ""} {
- set absolute_name [expr {
- [string match "::*" $proc_name]
- ? $proc_name : "::${proc_name}"
- }]
+
+ set absolute_name [expr {[string match "::*" $proc_name]
+ ? $proc_name : "::${proc_name}" }]
+
if {[is_object $scope $absolute_name]} {
set url [::xo::api object_url \
-show_source 1 -show_methods 2 \
Index: openacs-4/packages/acs-api-browser/tcl/test/acs-api-browser-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-api-browser/tcl/test/acs-api-browser-procs.tcl,v
diff -u -r1.4.2.23 -r1.4.2.24
--- openacs-4/packages/acs-api-browser/tcl/test/acs-api-browser-procs.tcl 16 Feb 2021 20:59:02 -0000 1.4.2.23
+++ openacs-4/packages/acs-api-browser/tcl/test/acs-api-browser-procs.tcl 19 Feb 2021 10:08:49 -0000 1.4.2.24
@@ -402,6 +402,67 @@
}
+aa_register_case \
+ -cats {smoke production_safe} \
+ -procs {
+ aa_error
+ api_called_proc_names
+ apidoc::get_doc_property
+ } \
+ callgraph__bad_calls {
+
+ Checks for calls of deprecated procs and for private calls in
+ other packages. Remember: "private" means "package private", a
+ "private" proc must be only directly called by a proc of the
+ same package
+
+ This test covers only library functions.
+
+ @author Gustaf Neumann
+
+ @creation-date 2020-02-18
+ } {
+
+ foreach caller [lsort -dictionary [nsv_array names api_proc_doc]] {
+ #set caller db_transaction
+ set called_procs [api_called_proc_names -proc_name $caller]
+ set caller_deprecated_p [apidoc::get_doc_property $caller deprecated_p 0]
+ set caller_package_key [apidoc::get_doc_property $caller package_key ""]
+ foreach called $called_procs {
+ #ns_log notice "$caller calls $called"
+ set msg "proc $caller calls deprecated proc: $called"
+ if {[apidoc::get_doc_property $called deprecated_p 0]} {
+ if {$caller_deprecated_p} {
+ aa_log_result warning "deprecated $msg"
+ } else {
+ aa_error "$msg
\
+ [apidoc::get_doc_property $caller script]
\
+ [apidoc::get_doc_property $called script]
"
+ }
+ }
+ set package_key [apidoc::get_doc_property $called package_key ""]
+ if {$caller_package_key ne ""
+ && $package_key ne ""
+ && $caller_package_key ne $package_key
+ } {
+ if {[apidoc::get_doc_property $called protection public] eq "private"
+ && ![string match AcsSc.* $caller]
+ } {
+ set msg "proc $caller_package_key.$caller calls private $package_key.$called"
+ if {$caller_deprecated_p} {
+ aa_log_result warning "deprecated $msg"
+ } else {
+ aa_error "$msg
\
+ [apidoc::get_doc_property $caller script]
\
+ [apidoc::get_doc_property $called script]
"
+ }
+ }
+ }
+ }
+ }
+ }
+}
+
# Local variables:
# mode: tcl
# tcl-indent-level: 4