Skip to content

A
acs-tcl
Commit 7b8caaf3 authored by Frank Bergmann's avatar Frank Bergmann
Browse files
Options

- OpenACS 5.9

parent 908ef174
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 3344 additions and 1953 deletions
acs-tcl.info
View file @ 7b8caaf3
......@@ -2,25 +2,25 @@
<!-- Generated by the OpenACS Package Manager -->
<package key="acs-tcl" url="http://openacs.org/repository/apm/packages/acs-tcl" type="apm_service">
<package-name>Tcl Library</package-name>
<pretty-plural>Tcl Libraries</pretty-plural>
<package-name>ACS Tcl Library</package-name>
<pretty-plural>ACS Tcl Libraries</pretty-plural>
<initial-install-p>t</initial-install-p>
<singleton-p>t</singleton-p>
<implements-subsite-p>f</implements-subsite-p>
<inherit-templates-p>t</inherit-templates-p>
<version name="5.10.0d1" url="http://openacs.org/repository/download/apm/acs-tcl-5.10.0d1.apm">
<version name="5.9.0" url="http://openacs.org/repository/download/apm/acs-tcl-5.9.0.apm">
<owner url="http://openacs.org">OpenACS</owner>
<summary>The Kernel Tcl API library.</summary>
<release-date>2013-09-08</release-date>
<release-date>2015-10-04</release-date>
<vendor url="http://openacs.org">OpenACS</vendor>
<description format="text/html">Contains all the core Tcl API, including the request processor, security and session management, permissions, site-nodes, package management infrastructure, etc.</description>
<license>GPL version 2</license>
<maturity>3</maturity>
<provides url="acs-tcl" version="5.10.0d1"/>
<requires url="acs-bootstrap-installer" version="5.10.0d1"/>
<requires url="acs-kernel" version="5.10.0d1"/>
<provides url="acs-tcl" version="5.9.0"/>
<requires url="acs-bootstrap-installer" version="5.9.0"/>
<requires url="acs-kernel" version="5.9.0"/>
<callbacks>
</callbacks>
......@@ -29,11 +29,11 @@
<parameter scope="instance" datatype="string" min_n_values="1" max_n_values="1" name="ReturnComplaint" default="/packages/acs-tcl/lib/ad-return-complaint" description="Template to use for the complaint page."/>
<parameter scope="instance" datatype="string" min_n_values="1" max_n_values="1" name="ReturnError" default="/packages/acs-tcl/lib/ad-return-error" description="Template to use for the complaint page."/>
<parameter scope="instance" datatype="string" min_n_values="1" max_n_values="1" name="SuppressHttpPort" default="0" description="Set to 1 to suppress the server's configured port --useful for example, when server is behind a proxy and: connection is switching from https to http or kernel's parameter ForceHostP is set to 1."/>
<parameter scope="instance" datatype="string" min_n_values="1" max_n_values="1" name="TclTraceLogServerities" description="If this parameter is set to a value different from empty then the value is expected to be a list of log severities (such as &quot;Notice Warning Error Bug Dev&quot;). If the command ns_log is issued with one of the configured severity the line is displayed via the developer support debug messsage (via ds_comment).
<parameter scope="instance" datatype="string" min_n_values="1" max_n_values="1" name="TclTraceLogServerities" description="If this parameter is set to a value different from empty then the value is expected to be a list of log severities (such as &quot;Notice Warning Error Bug Dev&quot;). If the command ns_log is issued with one of the configured severity the line is displayed via the developer support debug messsage (via ds_comment).
Activating this trace requires a new start of the server." section_name="tcltrace"/>
<parameter scope="instance" datatype="number" min_n_values="1" max_n_values="1" name="TclTraceSaveNsReturn" default="0" description="When this parameter is set to 1, the content pages returned by the server via ns_return with status code 200 and type text/html are saved in the configured tmp directory. The exact full path is logged in the error.log.
<parameter scope="instance" datatype="number" min_n_values="1" max_n_values="1" name="TclTraceSaveNsReturn" default="0" description="When this parameter is set to 1, the content pages returned by the server via ns_return with status code 200 and type text/html are saved in the configured tmp directory. The exact full path is logged in the error.log.
Activating this trace requires a new start of the server." section_name="tcltrace"/>
<parameter scope="instance" datatype="string" min_n_values="1" max_n_values="1" name="UseHostnameDomainforReg" default="0" description="Set to 1 if website uses domains mapped in host_nodes for public users and the hostname's domain as defined in config.tcl for registering users and their sessions."/>
</parameters>
......
lib/actions.tcl
View file @ 7b8caaf3
......@@ -28,3 +28,9 @@ if {![catch {
}
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
lib/complain.adp
View file @ 7b8caaf3
......@@ -3,9 +3,9 @@
<p>
#acs-tcl.We_had#
<if @complaints:rowcount@ gt 1>#acs-tcl.some_problems#</if>
<else>#acs-tcl.a_problem#</else>
<if @complaints:rowcount@ gt 1>#acs-tcl.some_problems#</if><else>#acs-tcl.a_problem#</else>
#acs-tcl.with_your_input#
<if @context;literal@ ne "">(@context@)</if>
</p>
<ul>
......
lib/page-error.tcl
View file @ 7b8caaf3
......@@ -8,10 +8,6 @@ ad_page_contract {
@cvs-id $Id$
} {
{bug_number ""}
{prev_url "/intranet/"}
{user_id {[ad_conn user_id]}}
{error_file ""}
{error_url ""}
}
set show_patch_status open
......@@ -44,13 +40,13 @@ set error_desc_email "
<strong>[_ acs-tcl.File]</strong> [ns_quotehtml $error_file]<br>
<strong>[_ acs-tcl.User_Name]</strong> [ns_quotehtml $user_name]<br>
<strong>[_ acs-tcl.lt_User_Id_of_the_user_t]</strong> [ns_quotehtml $user_id]<br>
<strong>IP:</strong> [ad_quotehtml [ns_conn peeraddr]]<br>
<strong>IP:</strong> [ns_quotehtml [ns_conn peeraddr]]<br>
<strong>[_ acs-tcl.Browser_of_the_user]</strong> [ns_quotehtml [ns_set get [ns_conn headers] User-Agent]]<br>
<br>
-----------------------------<br>
[_ acs-tcl.Error_details]<br>
-----------------------------<br>
<pre>[ad_quotehtml $error_info]</pre>
<pre>[ns_quotehtml $error_info]</pre>
<br>
------------------------------<br>
<br>
......@@ -266,15 +262,15 @@ if {$auto_submit_p && $user_id > 0} {
-------------------------------------------------------- <br>
[_ acs-tcl.Error_Report] <br>
-------------------------------------------------------- <br>
<br><strong>[_ acs-tcl.Previus]</strong> [ad_quotehtml $prev_url]
<br><strong>[_ acs-tcl.Page]</strong> [ad_quotehtml $error_url]
<br><strong>[_ acs-tcl.File]</strong> [ad_quotehtml $error_file]
<br><strong>[_ acs-tcl.User_Name]</strong> [ad_quotehtml $user_name]
<br><strong>[_ acs-tcl.lt_User_Id_of_the_user_t]</strong> [ad_quotehtml $user_id]
<br>[_ acs-tcl.Browser_of_the_user]</strong> [ad_quotehtml [ns_set get [ns_conn headers] User-Agent]]
<br><strong>[_ acs-tcl.Previus]</strong> [ns_quotehtml $prev_url]
<br><strong>[_ acs-tcl.Page]</strong> [ns_quotehtml $error_url]
<br><strong>[_ acs-tcl.File]</strong> [ns_quotehtml $error_file]
<br><strong>[_ acs-tcl.User_Name]</strong> [ns_quotehtml $user_name]
<br><strong>[_ acs-tcl.lt_User_Id_of_the_user_t]</strong> [ns_quotehtml $user_id]
<br>[_ acs-tcl.Browser_of_the_user]</strong> [ns_quotehtml [ns_set get [ns_conn headers] User-Agent]]
<br><br><strong>[_ acs-tcl.User_comments]</strong>
<br>
[ad_quotehtml [template::util::richtext::get_property contents $description]]<br>
[ns_quotehtml [template::util::richtext::get_property contents $description]]<br>
<br>"
foreach available_enabled_action_id [workflow::case::get_available_enabled_action_ids -case_id $case_id] {
......@@ -409,3 +405,9 @@ if { ![form is_valid bug_edit] } {
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
lib/static-progress-bar.tcl
View file @ 7b8caaf3
......@@ -53,3 +53,9 @@ if { ($total == 0) || [string is true $finish] } {
set percentage_done [expr {round(($current - 1) * 100.0 / $total)}]
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/00-database-procs-oracle.tcl
View file @ 7b8caaf3
......@@ -11,3 +11,9 @@ ad_library {
# 00-database-procs.tcl, so that all supported databases are useable
# with the db_* API all the time, regardless of which database type
# OpenACS is using. --atp@piskorski.com, 2003/04/09 12:04 EDT
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/00-database-procs-postgresql.tcl
View file @ 7b8caaf3
......@@ -11,3 +11,9 @@ ad_library {
# 00-database-procs.tcl, so that all supported databases are useable
# with the db_* API all the time, regardless of which database type
# OpenACS is using. --atp@piskorski.com, 2003/04/09 12:04 EDT
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/00-database-procs.tcl
View file @ 7b8caaf3
......@@ -68,7 +68,7 @@ ad_library {
# (JoelA, 27 Dec 2004 - replaced example config.tcl with link)
#
# see http://openacs.org/doc/openacs-5-1/tutorial-second-database.html
# see http://openacs.org/doc/openacs-5-1/tutorial-second-database
# for config and usage examples
# TODO: The "driverkey_" overrides in the config file are NOT
......@@ -113,11 +113,13 @@ ad_library {
# We now use the following global variables:
#
# Server-Wide NSV arrays, keys:
# db_default_database .
# db_available_pools $dbn
# db_driverkey $dbn
# db_pool_to_dbn $pool
#
# Global Variables
# ::acs::default_database
#
# Per-thread Tcl global variables:
# One Tcl Array per Database Name:
# db_state_${dbn}
......@@ -156,7 +158,7 @@ ad_proc -private db_state_array_name_is {
@creation-date 2003/03/16
} {
if { $dbn eq "" } {
set dbn [nsv_get {db_default_database} .]
set dbn $::acs::default_database
}
return "db_state_${dbn}"
}
......@@ -195,6 +197,11 @@ ad_proc -private db_driverkey {
}
}
set key ::acs::db_driverkey($dbn)
if {[info exists $key]} {
return [set $key]
}
if { ![nsv_exists db_driverkey $dbn] } {
# This ASSUMES that any overriding of this default value via
# "ns_param driverkey_dbn" has already been done:
......@@ -224,7 +231,7 @@ ad_proc -private db_driverkey {
nsv_set db_driverkey $dbn $driverkey
}
return [nsv_get db_driverkey $dbn]
return [set $key [nsv_get db_driverkey $dbn]]
}
......@@ -293,7 +300,7 @@ ad_proc -public db_known_database_types {} {
The nsv containing the list is initialized by the bootstrap script and should
never be referenced directly by user code.
} {
return [nsv_get ad_known_database_types .]
return $::acs::known_database_types
}
......@@ -357,7 +364,7 @@ ad_proc -public db_nextval {
@param dbn The database name to use. If empty_string, uses the default database.
@see <a href="/doc/db-api-detailed.html">/doc/db-api-detailed.html</a>
@see <a href="/doc/db-api-detailed">/doc/db-api-detailed</a>
} {
set driverkey [db_driverkey $dbn]
......@@ -663,7 +670,7 @@ ad_proc -public db_exec_plsql {
@param dbn The database name to use. If empty_string, uses the default database.
@see <a href="/doc/db-api-detailed.html">/doc/db-api-detailed.html</a>
@see <a href="/doc/db-api-detailed">/doc/db-api-detailed</a>
} {
ad_arg_parser { bind_output bind } $args
......@@ -1867,7 +1874,7 @@ ad_proc -public db_dml {{-dbn ""} statement_name sql args } {
@param dbn The database name to use. If empty_string, uses the default database.
@see <a href="/doc/db-api-detailed.html">/doc/db-api-detailed.html</a>
@see <a href="/doc/db-api-detailed">/doc/db-api-detailed</a>
} {
ad_arg_parser { clobs blobs clob_files blob_files bind } $args
set driverkey [db_driverkey $dbn]
......@@ -2536,7 +2543,7 @@ ad_proc -public db_source_sql_file {
while { [gets $fp line] >= 0 } {
# Don't bother writing out lines which are purely whitespace.
if { ![string is space $line] } {
apm_callback_and_log $callback "[ad_quotehtml $line]\n"
apm_callback_and_log $callback "[ns_quotehtml $line]\n"
}
}
close $fp
......@@ -2581,7 +2588,7 @@ ad_proc -public db_source_sql_file {
while { [gets $fp line] >= 0 } {
# Don't bother writing out lines which are purely whitespace.
if { ![string is space $line] } {
apm_callback_and_log $callback "[ad_quotehtml $line]\n"
apm_callback_and_log $callback "[ns_quotehtml $line]\n"
}
}
......@@ -2604,8 +2611,9 @@ ad_proc -public db_source_sql_file {
foreach line [split $error "\n"] {
if { [string first NOTICE $line] == -1 } {
append error_lines "$line\n"
set error_found [expr { $error_found || [string first ERROR $line] != -1 || \
[string first FATAL $line] != -1 } ]
set error_found [expr { $error_found
|| [string first ERROR $line] != -1
|| [string first FATAL $line] != -1 } ]
}
}
......@@ -2666,7 +2674,7 @@ ad_proc -public db_load_sql_data {
while { [gets $fd line] >= 0 } {
# Don't bother writing out lines which are purely whitespace.
if { ![string is space $line] } {
apm_callback_and_log $callback "[ad_quotehtml $line]\n"
apm_callback_and_log $callback "[ns_quotehtml $line]\n"
}
}
close $fd
......@@ -2711,7 +2719,7 @@ ad_proc -public db_load_sql_data {
while { [gets $fp line] >= 0 } {
# Don't bother writing out lines which are purely whitespace.
if { ![string is space $line] } {
apm_callback_and_log $callback "[ad_quotehtml $line]\n"
apm_callback_and_log $callback "[ns_quotehtml $line]\n"
}
}
......@@ -2737,8 +2745,9 @@ ad_proc -public db_load_sql_data {
foreach line [split $error "\n"] {
if { [string first NOTICE $line] == -1 } {
append error_lines "$line\n"
set error_found [expr { $error_found || [string first ERROR $line] != -1 || \
[string first FATAL $line] != -1 } ]
set error_found [expr { $error_found
|| [string first ERROR $line] != -1
|| [string first FATAL $line] != -1 } ]
}
}
......@@ -2777,13 +2786,13 @@ ad_proc -public db_source_sqlj_file {
while { [gets $fp line] >= 0 } {
# Don't bother writing out lines which are purely whitespace.
if { ![string is space $line] } {
apm_callback_and_log $callback "[ad_quotehtml $line]\n"
apm_callback_and_log $callback "[ns_quotehtml $line]\n"
}
}
if { [catch {
close $fp
} errmsg] } {
apm_callback_and_log $callback "[ad_quotehtml $errmsg]\n"
apm_callback_and_log $callback "[ns_quotehtml $errmsg]\n"
}
}
......@@ -3532,3 +3541,9 @@ ad_proc -public db_bounce_pools {{-dbn ""}} {
ns_db bouncepool $pool
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/10-charset-compat-procs.tcl
View file @ 7b8caaf3
......@@ -16,3 +16,9 @@ foreach one_proc $compat_procs {
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/20-memoize-init.tcl
View file @ 7b8caaf3
......@@ -36,3 +36,9 @@ ad_proc -public util_memoize_flush {script} {
} $flush_body
unset flush_body
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/30-xml-utils-procs.tcl
View file @ 7b8caaf3
......@@ -107,3 +107,9 @@ proc xml_doc_render {doc_id {indent_p f}} {
proc xml_node_get_children_by_select {parent_node xpath} {
return [$parent_node selectNodes $xpath]
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/acs-kernel-procs.tcl
View file @ 7b8caaf3
......@@ -55,3 +55,9 @@ ad_proc -public ad_verify_install {} {
return 0
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/acs-permissions-procs.tcl
View file @ 7b8caaf3
......@@ -337,3 +337,9 @@ ad_proc -private -deprecated ad_user_filter {} {
permission::require_permission -object_id [ad_conn object_id] -privilege "read"
return filter_ok
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/acs-private-data-procs.tcl
View file @ 7b8caaf3
......@@ -53,3 +53,9 @@ namespace eval acs_privacy {
}
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/ad-functional-procs.tcl
View file @ 7b8caaf3
......@@ -773,3 +773,9 @@ proc multiplication_table {x} {
namespace export *
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/admin-init.tcl
View file @ 7b8caaf3
......@@ -35,3 +35,9 @@ if { [parameter::get -package_id [ad_acs_kernel_id] -parameter RegisterRestrictE
ad_register_filter preauth HEAD "${url}*" ad_restrict_entire_server_to_registered_users
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/admin-procs.tcl
View file @ 7b8caaf3
......@@ -236,3 +236,9 @@ ad_proc -private ad_registration_finite_state_machine_admin_links {
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/adp-parser-procs.tcl
View file @ 7b8caaf3
......@@ -179,14 +179,11 @@ ad_proc -public doc_adp_execute {
set errno [catch { doc_eval_in_separate_frame $compiled_adp } error]
incr doc_adp_depth -1
global errorCode
if { $errno == 0 || $errorCode eq "doc_adp_abort" } {
if { $errno == 0 || $::errorCode eq "doc_adp_abort" } {
return $adp_var
}
global errorInfo
return -code $errno -errorcode $errorCode -errorinfo $errorInfo $error
return -code $errno -errorcode $::errorCode -errorinfo $::errorInfo $error
}
ad_proc -public doc_adp_puts { value } {
......@@ -408,3 +405,9 @@ ad_proc -public doc_adp_compile { adp } {
return $code
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/aolserver-3-procs.tcl
View file @ 7b8caaf3
......@@ -178,3 +178,9 @@ proc _ns_timeentrywidget {column} {
return [ns_dbformvalueput $output $column time [lindex [split [ns_localsqltimestamp] " "] 1]]
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/apm-file-procs.tcl
View file @ 7b8caaf3
......@@ -367,8 +367,7 @@ ad_proc -public apm_file_watchable_p { path } {
# Check the db type
set file_db_type [apm_guess_db_type $package_key $package_rel_path]
set right_db_type_p [expr {$file_db_type eq ""} || \
[string equal $file_db_type [db_type]]]
set right_db_type_p [expr {$file_db_type eq "" || $file_db_type eq [db_type]}]
# Check the file type
set file_type [apm_guess_file_type $package_key $package_rel_path]
......@@ -580,7 +579,7 @@ ad_proc -private apm_load_apm_file {
apm_callback_and_log $callback "<li>Downloading $url..."
if { [catch {apm_transfer_file -url $url -output_file_name $file_path} errmsg] } {
apm_callback_and_log $callback "Unable to download. Please check your URL.</ul>.
The following error was returned: <blockquote><pre>[ad_quotehtml $errmsg]
The following error was returned: <blockquote><pre>[ns_quotehtml $errmsg]
</pre></blockquote>"
return
}
......@@ -601,10 +600,9 @@ ad_proc -private apm_load_apm_file {
apm_callback_and_log $callback "<li>Done. Archive is [format %.1f [expr { [file size $file_path] / 1024.0 }]]KB, with [llength $files] files.<li>"
} errmsg] } {
apm_callback_and_log $callback "The follow error occured during the uncompression process:
<blockquote><pre>[ad_quotehtml $errmsg]</pre></blockquote><br>
<blockquote><pre>[ns_quotehtml $errmsg]</pre></blockquote><br>
"
global errorInfo
ns_log Error "Error loading APM file form url $url: $errmsg\n$errorInfo"
ns_log Error "Error loading APM file form url $url: $errmsg\n$::errorInfo"
return
}
......@@ -658,12 +656,11 @@ ad_proc -private apm_load_apm_file {
file delete -force $tmpdir
apm_callback_and_log $callback "The archive contains an unparseable package specification file:
<code>$info_file</code>. The following error was produced while trying to
parse it: <blockquote><pre>[ad_quotehtml $errmsg]</pre></blockquote>.
parse it: <blockquote><pre>[ns_quotehtml $errmsg]</pre></blockquote>.
<p>
The package cannot be installed.
</ul>\n"
global errorInfo
ns_log Error "Error loading APM file form url $url: Bad package .info file. $errmsg\n$errorInfo"
ns_log Error "Error loading APM file form url $url: Bad package .info file. $errmsg\n$::errorInfo"
return
}
file delete -force $tmpdir
......
tcl/apm-init.tcl
View file @ 7b8caaf3
......@@ -11,3 +11,9 @@ nsv_array set apm_version_procs_loaded_p [list]
nsv_array set apm_reload_watch [list]
nsv_array set apm_package_info [list]
nsv_set apm_properties reload_level 0
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/apm-install-procs.tcl
View file @ 7b8caaf3
......@@ -124,7 +124,10 @@ ad_proc -public apm_dependency_provided_p {
}
}
ad_proc -private pkg_info_new { package_key spec_file_path embeds extends provides requires {dependency_p ""} {comment ""}} {
ad_proc -private pkg_info_new {
package_key spec_file_path embeds extends provides requires
{dependency_p ""} {comment ""}
} {
Returns a datastructure that maintains information about a package.
@param package_key The key of the package.
......@@ -534,8 +537,9 @@ ad_proc -private apm_dependency_check_new {
lassign $prov prov_uri prov_version
# If what we provide is not already provided, or the alredady provided version is
# less than what we provide, record this new provision
if { ![info exists provided($prov_uri)] || \
[apm_version_names_compare $provided($prov_uri) $prov_version] == -1 } {
if { ![info exists provided($prov_uri)]
|| [apm_version_names_compare $provided($prov_uri) $prov_version] == -1
} {
set provided($prov_uri) $prov_version
}
# If what we provide is required, and the required version is less than what we provide,
......@@ -767,12 +771,18 @@ ad_proc -private apm_package_install {
array set version [apm_read_package_info_file $spec_file_path]
set package_key $version(package.key)
apm_callback_and_log $callback "<h3>Installing $version(package-name) $version(name)</h3>"
# Determine if we are upgrading or installing.
set upgrade_from_version_name [apm_package_upgrade_from $package_key $version(name)]
set upgrade_p [expr {$upgrade_from_version_name ne ""}]
if {$upgrade_p} {
set operations {Upgrading Upgraded}
} else {
set operations {Installing Installed}
}
apm_callback_and_log $callback "<h3>[lindex $operations 0] $version(package-name) $version(name)</h3>"
if { [string match "[apm_workspace_install_dir]*" $package_path] } {
# Package is being installed from the apm_workspace dir (expanded from .apm file)
......@@ -914,15 +924,14 @@ ad_proc -private apm_package_install {
apm_package_install_owners -callback $callback $version(owners) $version_id
apm_package_install_callbacks -callback $callback $version(callbacks) $version_id
apm_build_subsite_packages_list
apm_callback_and_log $callback "<p>Installed $version(package-name), version $version(name).</p>"
apm_callback_and_log $callback "<p>[lindex $operations 1] $version(package-name), version $version(name).</p>"
} {
global errorInfo
ns_log Error "apm_package_install: Error installing $version(package-name) version $version(name): $errmsg\n$errorInfo"
ns_log Error "apm_package_install: Error installing $version(package-name) version $version(name): $errmsg\n$::errorInfo"
apm_callback_and_log -severity Error $callback [subst {<p>Failed to install $version(package-name), version $version(name). The following error was generated:
<pre><blockquote>
[ad_quotehtml $errmsg]
[ns_quotehtml $errmsg]
</blockquote></pre>
<p>
......@@ -977,9 +986,8 @@ ad_proc -private apm_package_install {
apm_callback_and_log $callback "<p> Mounted an instance of the package at /${priority_mount_path} </p>"
} {
# Another package is mounted at the path so we cannot mount
global errorInfo
set error_text "Package $version(package-name) could not be mounted at /$version(auto-mount) , there may already be a package mounted there, the error is: $error"
ns_log Error "apm_package_install: $error_text \n\n$errorInfo"
ns_log Error "apm_package_install: $error_text \n\n$::errorInfo"
apm_callback_and_log $callback "<p> $error_text </p>"
}
......@@ -990,9 +998,18 @@ ad_proc -private apm_package_install {
apm_package_instance_new -instance_name $version(package-name) \
-package_key $package_key
}
if {[file exists $::acs::rootdir/packages/$package_key/install.xml]} {
# Run install.xml only for new installs
ns_log notice "===== RUN /packages/$package_key/install.xml"
apm::process_install_xml /packages/$package_key/install.xml ""
}
} else {
# After upgrade Tcl proc callback
apm_invoke_callback_proc -version_id $version_id -type after-upgrade -arg_list [list from_version_name $upgrade_from_version_name to_version_name $version(name)]
apm_invoke_callback_proc -version_id $version_id -type after-upgrade \
-arg_list [list from_version_name $upgrade_from_version_name to_version_name $version(name)]
}
# Flush the installed_p cache
......@@ -1004,7 +1021,7 @@ ad_proc -private apm_package_install {
ad_proc apm_unregister_disinherited_params { package_key dependency_id } {
Remove parameters for package_key that have been disinherited (i.e., the
dependency that caused them to be inherited have been removed). Called only
dependency that caused them to be inherited have been removed). Called only
by the APM and keep it that way, please.
} {
......@@ -1096,7 +1113,7 @@ ad_proc -private apm_package_deinstall {
# the backup directory for the package.
regsub {@.+} [cc_email_from_party [ad_conn user_id]] "" my_email_name
set backup_dir "[apm_workspace_dir]/$package_key-removed-$my_email_name-[ns_fmttime [ns_time] "%Y%m%d-%H:%M:%S"]"
set backup_dir "[apm_workspace_dir]/$package_key-removed-$my_email_name-[ns_fmttime [ns_time] {%Y%m%d-%H:%M:%S}]"
apm_callback_and_log $callback "
<li>Moving <tt>packages/$package_key</tt> to $backup_dir... "
......@@ -1630,10 +1647,9 @@ ad_proc -private apm_packages_full_install {
$spec_file
} errmsg] } {
global errorInfo
apm_callback_and_log -severity Error $callback "<p><font color=red>[string totitle $package_key] not installed.</font>
<p> Error:
<pre><blockquote>[ad_quotehtml $errmsg]</blockquote><blockquote>[ad_quotehtml $errorInfo]</blockquote></pre>"
<pre><blockquote>[ns_quotehtml $errmsg]</blockquote><blockquote>[ns_quotehtml $::errorInfo]</blockquote></pre>"
}
}
}
......@@ -2172,8 +2188,7 @@ ad_proc -private apm_get_package_repository {
} {
# We don't error hard here, because we don't want the whole process to fail if there's just one
# package with a bad .info file
global errorInfo
ns_log Error "apm_get_package_repository: Error while checking package info file $spec_file: $errmsg\n$errorInfo"
ns_log Error "apm_get_package_repository: Error while checking package info file $spec_file: $errmsg\n$::errorInfo"
}
}
}
......@@ -2199,13 +2214,17 @@ ad_proc -public apm_get_repository_channels { {repository_url http://openacs.org
set repositories ""
dom parse -simple -html [dict get $result page] doc
$doc documentElement root
foreach node [$root selectNodes //ul/li] {
set txt [$node asText]
if {![regexp {^(\S+)\s[\(]([^\)]+)\)} $txt _ name tag]} {
foreach node [$root selectNodes {//ul/li/a}] {
set href [$node getAttribute href]
if {[regexp {(\d+[-]\d+)} $href . version]} {
set name $version
set tag oacs-$version
lappend repositories [list $name $tag]
} else {
set txt [string trim [$node asText]]
ns_log warning "unexpected li found in repository $repository_url: $txt"
continue
}
lappend repositories [list $name $tag]
}
return $repositories
}
......@@ -2236,7 +2255,7 @@ ad_proc -private apm_load_install_xml {filename binds} {
# Interpolate the vars.
if {$binds ne ""} {
foreach {var val} $binds {
set $var [ad_quotehtml $val]
set $var [ns_quotehtml $val]
}
if {![info exists Id]} {
set Id {$Id}
......@@ -2490,7 +2509,12 @@ ad_proc -private apm::package_version::attributes::maturity_int_to_text { maturi
set maturity_key(3) "#acs-tcl.maturity_mature_and_standard#"
set maturity_key(4) "#acs-tcl.maturity_deprecated#"
set result [lang::util::localize $maturity_key($maturity)]
if {[catch {
set result [lang::util::localize $maturity_key($maturity)]
} errorMsg]} {
ns_log warning "Couldn't localize maturity key $maturity: $errorMsg"
set result $maturity
}
} else {
......@@ -2633,9 +2657,9 @@ ad_proc -private apm::package_version::attributes::generate_xml_element {
}
} else {
if {$attribute_name eq ""} {
set xml_string "${indentation}<${element_name}>[ad_quotehtml $value]</${element_name}>\n"
set xml_string "${indentation}<${element_name}>[ns_quotehtml $value]</${element_name}>\n"
} else {
set xml_string "${indentation}<$element_name $attribute_name=\"[ad_quotehtml $value]\"/>\n"
set xml_string "${indentation}<$element_name $attribute_name=\"[ns_quotehtml $value]\"/>\n"
}
}
return $xml_string
......
tcl/apm-procs.tcl
View file @ 7b8caaf3
......@@ -908,7 +908,14 @@ ad_proc -public apm_package_installed_p {
ad_proc -private apm_package_installed_p_not_cached {
package_key
} {
return [db_string apm_package_installed_p {} -default 0]
if {[catch {set installed_p [db_string apm_package_installed_p {
select 1 from apm_package_versions
where package_key = :package_key
and installed_p = 't'
} -default 0]}]} {
set installed_p 0
}
return $installed_p
}
ad_proc -public apm_package_enabled_p {
......@@ -1232,8 +1239,12 @@ ad_proc -public apm_package_id_from_key {package_key} {
} {
set var ::apm::package_id_from_key($package_key)
if {[info exists $var]} {return [set $var]}
set $var [util_memoize [list apm_package_id_from_key_mem $package_key]]
#set $var [ns_cache_eval ns:memoize apm_package_id_from_key_$package_key [list apm_package_id_from_key_mem $package_key]]
set result [util_memoize [list apm_package_id_from_key_mem $package_key]]
#set result [ns_cache_eval ns:memoize apm_package_id_from_key_$package_key [list apm_package_id_from_key_mem $package_key]]
if {$result != 0} {
set $var $result
}
return $result
}
ad_proc -private apm_package_id_from_key_mem {package_key} {
......@@ -1863,8 +1874,9 @@ ad_proc -public apm_get_installed_provides {
and d.version_id = v.version_id
and v.enabled_p = 't'
} {
if { ![info exists installed_provides($service_uri)] || \
[apm_version_names_compare $installed_provides($service_uri) $service_version] == -1 } {
if { ![info exists installed_provides($service_uri)]
|| [apm_version_names_compare $installed_provides($service_uri) $service_version] == -1
} {
set installed_provides($service_uri) $service_version
}
}
......
tcl/apm-procs.xql
View file @ 7b8caaf3
......@@ -126,14 +126,6 @@
</querytext>
</fullquery>
<fullquery name="apm_package_installed_p_not_cached.apm_package_installed_p">
<querytext>
select 1 from apm_package_versions
where package_key = :package_key
and installed_p = 't'
</querytext>
</fullquery>
<fullquery name="apm_package_enabled_p.apm_package_enabled_p">
<querytext>
select 1 from apm_package_versions
......
tcl/apm-xml-procs.tcl
View file @ 7b8caaf3
......@@ -67,44 +67,44 @@ ad_proc -private apm_generate_package_spec { version_id } {
append spec "<?xml version=\"1.0\"?>
<!-- Generated by the OpenACS Package Manager -->
<package key=\"[ad_quotehtml $package_key]\" url=\"[ad_quotehtml $package_uri]\" type=\"$package_type\">
<package-name>[ad_quotehtml $pretty_name]</package-name>
<pretty-plural>[ad_quotehtml $pretty_plural]</pretty-plural>
<package key=\"[ns_quotehtml $package_key]\" url=\"[ns_quotehtml $package_uri]\" type=\"$package_type\">
<package-name>[ns_quotehtml $pretty_name]</package-name>
<pretty-plural>[ns_quotehtml $pretty_plural]</pretty-plural>
<initial-install-p>$initial_install_p</initial-install-p>
<singleton-p>$singleton_p</singleton-p>
<implements-subsite-p>$implements_subsite_p</implements-subsite-p>
<inherit-templates-p>$inherit_templates_p</inherit-templates-p>
${auto_mount_tag}
<version name=\"$version_name\" url=\"[ad_quotehtml $version_uri]\">\n"
<version name=\"$version_name\" url=\"[ns_quotehtml $version_uri]\">\n"
db_foreach owner_info {} {
append spec " <owner"
if { $owner_uri ne "" } {
append spec " url=\"[ad_quotehtml $owner_uri]\""
append spec " url=\"[ns_quotehtml $owner_uri]\""
}
append spec ">[ad_quotehtml $owner_name]</owner>\n"
append spec ">[ns_quotehtml $owner_name]</owner>\n"
}
apm_log APMDebug "APM: Writing Version summary and description"
if { $summary ne "" } {
append spec " <summary>[ad_quotehtml $summary]</summary>\n"
append spec " <summary>[ns_quotehtml $summary]</summary>\n"
}
if { $release_date ne "" } {
append spec " <release-date>[ad_quotehtml [string range $release_date 0 9]]</release-date>\n"
append spec " <release-date>[ns_quotehtml [string range $release_date 0 9]]</release-date>\n"
}
if { $vendor ne "" || $vendor_uri ne "" } {
append spec " <vendor"
if { $vendor_uri ne "" } {
append spec " url=\"[ad_quotehtml $vendor_uri]\""
append spec " url=\"[ns_quotehtml $vendor_uri]\""
}
append spec ">[ad_quotehtml $vendor]</vendor>\n"
append spec ">[ns_quotehtml $vendor]</vendor>\n"
}
if { $description ne "" } {
append spec " <description"
if { $description_format ne "" } {
append spec " format=\"[ad_quotehtml $description_format]\""
append spec " format=\"[ns_quotehtml $description_format]\""
}
append spec ">[ad_quotehtml $description]</description>\n"
append spec ">[ns_quotehtml $description]</description>\n"
}
append spec [apm::package_version::attributes::generate_xml \
......@@ -115,7 +115,7 @@ ad_proc -private apm_generate_package_spec { version_id } {
apm_log APMDebug "APM: Writing Dependencies."
db_foreach dependency_info {} {
append spec " <$dependency_type url=\"[ad_quotehtml $service_uri]\" version=\"[ad_quotehtml $service_version]\"/>\n"
append spec " <$dependency_type url=\"[ns_quotehtml $service_uri]\" version=\"[ns_quotehtml $service_version]\"/>\n"
} else {
append spec " <!-- No dependency information -->\n"
}
......@@ -123,8 +123,8 @@ ad_proc -private apm_generate_package_spec { version_id } {
append spec "\n <callbacks>\n"
apm_log APMDebug "APM: Writing callbacks"
db_foreach callback_info {} {
append spec " <callback type=\"[ad_quotehtml $type]\" \
proc=\"[ad_quotehtml $proc]\"/>\n"
append spec " <callback type=\"[ns_quotehtml $type]\" \
proc=\"[ns_quotehtml $proc]\"/>\n"
}
append spec " </callbacks>"
append spec "\n <parameters>\n"
......@@ -133,20 +133,20 @@ ad_proc -private apm_generate_package_spec { version_id } {
set parent_package_keys [lrange [apm_one_package_inherit_order $package_key] 0 end-1]
db_foreach parameter_info {} {
append spec " <parameter scope=\"[ad_quotehtml $scope]\" datatype=\"[ad_quotehtml $datatype]\" \
min_n_values=\"[ad_quotehtml $min_n_values]\" \
max_n_values=\"[ad_quotehtml $max_n_values]\" \
name=\"[ad_quotehtml $parameter_name]\" "
append spec " <parameter scope=\"[ns_quotehtml $scope]\" datatype=\"[ns_quotehtml $datatype]\" \
min_n_values=\"[ns_quotehtml $min_n_values]\" \
max_n_values=\"[ns_quotehtml $max_n_values]\" \
name=\"[ns_quotehtml $parameter_name]\" "
if { $default_value ne "" } {
append spec " default=\"[ad_quotehtml $default_value]\""
append spec " default=\"[ns_quotehtml $default_value]\""
}
if { $description ne "" } {
append spec " description=\"[ad_quotehtml $description]\""
append spec " description=\"[ns_quotehtml $description]\""
}
if { $section_name ne "" } {
append spec " section_name=\"[ad_quotehtml $section_name]\""
append spec " section_name=\"[ns_quotehtml $section_name]\""
}
append spec "/>\n"
......@@ -202,7 +202,9 @@ ad_proc -public apm_read_package_info_file { path } {
<code>vendor</code>,
<code>group</code>,
<code>vendor.url</code>, and
<code>description.format</code>.
<code>description.format</code>,
<code>maturity</code>,
<code>maturity_text</code>.
</ul>
......@@ -276,9 +278,11 @@ ad_proc -public apm_read_package_info_file { path } {
set properties(url) [apm_required_attribute_value $version url]
# Set an entry in the properties array for each of these tags.
foreach property_name { summary description release-date vendor } {
set properties(maturity) ""
foreach property_name { summary description release-date vendor maturity } {
set properties($property_name) [apm_tag_value $version $property_name]
}
set properties(maturity_text) [apm::package_version::attributes::maturity_int_to_text $properties(maturity)]
apm::package_version::attributes::parse_xml \
-parent_node $version \
......@@ -420,3 +424,9 @@ ad_proc -public apm_read_package_info_file { path } {
return $return_value
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/application-data-link-procs.tcl
View file @ 7b8caaf3
......@@ -393,3 +393,9 @@ ad_proc -public application_data_link::relation_tag_where_clause {
return [db_map where_clause]
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/application-link-procs.tcl
View file @ 7b8caaf3
......@@ -119,3 +119,9 @@ ad_proc -private ::install::xml::action::application-link { node } {
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/callback-procs.tcl
View file @ 7b8caaf3
......@@ -36,3 +36,9 @@ ad_proc -public callback::get_object_type_impl {
return ""
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/community-core-2-procs.tcl
View file @ 7b8caaf3
......@@ -25,3 +25,9 @@ namespace eval oacs::user {
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/community-core-procs.tcl
View file @ 7b8caaf3
......@@ -703,3 +703,9 @@ ad_proc -public acs_user::get_portrait_id_not_cached {
} {
return [db_string get_item_id "" -default 0]
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/database-init.tcl
View file @ 7b8caaf3
......@@ -11,3 +11,9 @@ ad_library {
#DRB: the default value is needed during the initial install of OpenACS
ns_cache create db_cache_pool -size \
[parameter::get -package_id [ad_acs_kernel_id] -parameter DBCacheSize -default 50000]
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/defs-procs.tcl
View file @ 7b8caaf3
......@@ -853,3 +853,9 @@ ad_proc -public ad_progress_bar_end {
ns_write "<script type=\"text/javascript\">window.location='$url';</script>"
ns_conn close
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/deprecated-utilities-procs.tcl
View file @ 7b8caaf3
......@@ -177,3 +177,9 @@ ad_proc -public -deprecated proc_doc { args } {
} {
ad_proc {*}$args
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/document-init.tcl
View file @ 7b8caaf3
......@@ -10,3 +10,9 @@ ad_library {
ns_adp_registerscript ad-document "/ad-document" doc_tag_ad_document
ns_adp_registerscript ad-property "/ad-property" doc_tag_ad_property
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/document-procs.tcl
View file @ 7b8caaf3
......@@ -216,3 +216,9 @@ ad_proc -deprecated doc_tag_ad_property { contents params } {} {
}
doc_set_property $name $contents
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/ds-stub-procs.tcl
View file @ 7b8caaf3
......@@ -21,3 +21,9 @@ if {[info commands ds_collect_db_call] eq ""} {
if {[info commands ds_collect_connection_info] eq ""} {
proc ds_collect_connection_info {} {}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/exception-procs.tcl
View file @ 7b8caaf3
......@@ -55,3 +55,9 @@ ad_proc -private ad_try {code args} {
return -code $errno -errorcode $::errorCode -errorinfo $::errorInfo $result
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/form-processing-procs.tcl
View file @ 7b8caaf3
......@@ -262,8 +262,8 @@ ad_proc -public ad_form {
either a name, in which case the Tcl variable at the caller's level is passed to the form if it exists,
or a name-value pair.
The behavior of this option replicates that for <code>vars</code> argument in proc
<a href='/api-doc/proc-view?proc=export_vars&source_p=1'>export_vars</a>, which in turn follows specification
for input page variables in <a href='/api-doc/proc-view?proc=ad_page_contract&source_p=1'>ad_page_contract</a>.
<a href='/api-doc/proc-view?proc=export_vars&amp;source_p=1'>export_vars</a>, which in turn follows specification
for input page variables in <a href='/api-doc/proc-view?proc=ad_page_contract&amp;source_p=1'>ad_page_contract</a>.
In particular, flags <code>:multiple</code>, <code>:sign</code> and <code>:array</code> are allowed and
their meaning is the same as in <code>export_vars</code>.
</dd>
......
tcl/html-email-procs.tcl
View file @ 7b8caaf3
......@@ -153,3 +153,9 @@ ad_proc parse_incoming_email {
return $body
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/http-auth-procs.tcl
View file @ 7b8caaf3
......@@ -114,3 +114,9 @@ ad_proc http_auth::site_node_authorize {
return filter_return
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/image-procs.tcl
View file @ 7b8caaf3
......@@ -34,3 +34,9 @@ ad_proc -public image::get_info {
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/install-procs.tcl
View file @ 7b8caaf3
......@@ -1169,3 +1169,9 @@ ad_proc -public install::xml::util::get_id { id } {
return $result
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/json-procs.tcl
View file @ 7b8caaf3
......@@ -652,3 +652,9 @@ ad_proc util::json::indent {
}
return [join $output \n]
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/membership-rel-procs.tcl
View file @ 7b8caaf3
......@@ -110,3 +110,9 @@ namespace eval membership_rel {
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/memoize-procs.tcl
View file @ 7b8caaf3
......@@ -309,3 +309,9 @@ ad_proc -public util_memoize_flush_regexp {
}
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/navigation-callback-procs.tcl
View file @ 7b8caaf3
......@@ -59,3 +59,9 @@ ad_proc -public -callback navigation::package_admin {
@author Jeff Davis (davis@xarg.net)
} -
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/navigation-procs.tcl
View file @ 7b8caaf3
......@@ -72,7 +72,7 @@ ad_proc ad_context_node_list {
set node(instance_name) $node(name)
}
set context [concat [list [list $node(url) [ad_quotehtml $node(instance_name)]]] $context]
set context [concat [list [list $node(url) [ns_quotehtml $node(instance_name)]]] $context]
# We have the break here, so that 'from_node' itself is included
if {$node_id eq $from_node} {
......@@ -645,3 +645,9 @@ proc ad_menu_footer {{section ""}} {
return $return_string
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/object-procs-postgresql.xql
View file @ 7b8caaf3
......@@ -26,7 +26,6 @@
to_char(o.last_modified, 'YYYY-MM-DD HH24:MI:SS') as last_modified_ansi,
o.modifying_user,
o.modifying_ip,
o.tree_sortkey,
acs_object__name(o.object_id) as object_name
from acs_objects o
where o.object_id = :object_id
......
tcl/object-procs.tcl
View file @ 7b8caaf3
......@@ -151,3 +151,9 @@ ad_proc -public acs_object::set_context_id {
} {
db_dml update_context_id {}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/object-type-procs.tcl
View file @ 7b8caaf3
......@@ -160,3 +160,9 @@ ad_proc -private acs_object_type::get_table_name_not_cached {
} {
return [db_string get_table_name ""]
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/openacs-kernel-procs.tcl
View file @ 7b8caaf3
......@@ -110,8 +110,7 @@ ad_proc -public oacs_util::csv_foreach {
ns_getcsv $csv_stream headers
}
# provide access to errorInfo and errorCode
global errorInfo errorCode
# provide access to errorCode
# Upvar Magic!
upvar 1 $array_name row_array
......@@ -143,8 +142,8 @@ ad_proc -public oacs_util::csv_foreach {
# (source: http://wiki.tcl.tk/unless last case)
switch -exact -- $errno {
0 {}
1 {return -code error -errorinfo $errorInfo \
-errorcode $errorCode $error}
1 {return -code error -errorinfo $::errorInfo \
-errorcode $::errorCode $error}
2 {return $error}
3 {break}
4 {}
......@@ -167,3 +166,9 @@ ad_proc -public oacs_util::vars_to_ns_set {
ns_set put $ns_set $var $one_var
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/parameter-procs.tcl
View file @ 7b8caaf3
......@@ -98,8 +98,7 @@ ad_proc -public parameter::get_global_value {
set value 0
}
} errmsg] } {
global errorInfo
ns_log Error "Parameter $parameter not a boolean:\n$errorInfo"
ns_log Error "Parameter $parameter not a boolean:\n$::errorInfo"
set value $default
}
}
......@@ -152,10 +151,11 @@ ad_proc -public parameter::get {
}
set value ""
# 1. If there is not package_id provided, check whether there is a
# parameter by this name in the parameter file? Actually,
# ad_parameter_from_file is a misnomer, since the it checks ns_config
# values
# 1. check whether there is a parameter by this name specified for
# the packagin in the parameter file. The name
# ad_parameter_from_file is a misnomer, since the it checks
# ns_config values
#
if {$package_id ne ""} {
set package_key ""
# This can fail at server startup--OpenACS calls parameter::get to
......@@ -195,8 +195,7 @@ ad_proc -public parameter::get {
set value 0
}
} errmsg] } {
global errorInfo
ns_log Error "Parameter $parameter not a boolean:\n$errorInfo"
ns_log Error "Parameter $parameter not a boolean:\n$::errorInfo"
set value $default
}
}
......@@ -265,3 +264,9 @@ ad_proc -public parameter::get_from_package_key {
return $value
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/pdf-procs.tcl
View file @ 7b8caaf3
......@@ -131,3 +131,9 @@ ad_proc -private text_templates::create_html_content {
return $final_content
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/pools-init.tcl
View file @ 7b8caaf3
......@@ -47,3 +47,9 @@ if {[ns_info version] eq "4.5"} {
}
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/proxy-procs.tcl
View file @ 7b8caaf3
# packages/acs-tcl/tcl/proxy-procs.tcl
# packages/acs-tcl/tcl/proxy-procs.tcl
ad_library {
Proxy procs
......@@ -9,26 +8,32 @@ ad_library {
@cvs-id $Id$
}
# First check that ns_proxy is configured
if {![catch {set handler [ns_proxy get exec_proxy]}]} {
ns_proxy release $handler
#
# First check if ns_proxy is available
#
if {![catch {ns_proxy configure ExecPool -maxruns 0}]} {
namespace eval proxy {}
ad_proc -public proxy::exec {
{-call}
{-call}
{-cd}
} {
Execute the statement in a proxy instead of normal exec
@param call Call which is passed to the "exec" command
Execute the statement in a proxy instead of normal exec
@param call Call which is passed to the "exec" command (required)
@param cd change to the given directory before executing the command
} {
set handle [ns_proxy get exec_proxy]
with_finally -code {
set return_string [ns_proxy eval $handle "exec $call"]
} -finally {
ns_proxy release $handle
}
return $return_string
set handle [ns_proxy get ExecPool]
with_finally -code {
if {[info exists cd]} {
ns_proxy eval $handle [list cd $cd]
}
set return_string [ns_proxy eval $handle [list ::exec {*}$call]]
} -finally {
ns_proxy release $handle
}
return $return_string
}
# Now rename exec; protect cases, where file is loaded multiple times
......@@ -36,3 +41,9 @@ if {![catch {set handler [ns_proxy get exec_proxy]}]} {
ad_proc exec {args} {This is the wrapped version of exec} {proxy::exec -call $args}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/request-processor-init.tcl
View file @ 7b8caaf3
......@@ -173,9 +173,15 @@ ad_after_server_initialization procs_register {
}
ns_log Notice "ns_register_proc $noinherit_switch [list $method $path rp_invoke_proc [list $proc_index $debug_p $arg_count $proc $arg]]"
eval ns_register_proc $noinherit_switch \
[list $method $path rp_invoke_proc [list $proc_index $debug_p $arg_count $proc $arg]]
ns_register_proc {*}$noinherit_switch \
$method $path rp_invoke_proc [list $proc_index $debug_p $arg_count $proc $arg]
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/request-processor-procs.tcl
View file @ 7b8caaf3
......@@ -213,7 +213,7 @@ ad_proc -public ad_register_proc {
} {
Registers a procedure (see ns_register_proc for syntax). Use a
method of "*" to register GET, POST, and HEAD PUT DELETE filters. If debug is
method of "*" to register GET, POST, and HEAD filters. If debug is
set to "t", all invocations of the procedure will be logged in the
server log.
......@@ -224,14 +224,14 @@ ad_proc -public ad_register_proc {
if {$method eq "*"} {
# Shortcut to allow registering filter for all methods. Just
# call ad_register_proc again, with each of the three methods.
foreach method { GET POST HEAD PUT DELETE } {
foreach method { GET POST HEAD } {
ad_register_proc -debug $debug -noinherit $noinherit $method $path $proc $arg
}
return
}
if {$method ni { GET POST HEAD PUT DELETE }} {
error "Method passed to ad_register_proc must be one of GET, POST, or HEAD PUT DELETE"
error "Method passed to ad_register_proc must be one of GET, POST, HEAD, PUT and DELETE"
}
set proc_info [list $method $path $proc $arg $debug $noinherit $description [info script]]
......@@ -339,7 +339,7 @@ ad_proc -private rp_invoke_proc { conn argv } {
ad_proc -private rp_finish_serving_page {} {
global doc_properties
if { [info exists doc_properties(body)] } {
rp_debug "Returning page:[info level [expr {[info level] - 1}]]: [ad_quotehtml [string range $doc_properties(body) 0 100]]"
rp_debug "Returning page:[info level [expr {[info level] - 1}]]: [ns_quotehtml [string range $doc_properties(body) 0 100]]"
doc_return 200 text/html $doc_properties(body)
}
}
......@@ -367,7 +367,7 @@ ad_proc -public ad_register_filter {
@param kind Specify preauth, postauth or trace.
@param method Use a method of "*" to register GET, POST, and HEAD PUT DELETE
@param method Use a method of "*" to register GET, POST, and HEAD
filters.
@param priority Priority is an integer; lower numbers indicate
......@@ -385,14 +385,14 @@ ad_proc -public ad_register_filter {
} {
if {$method eq "*"} {
# Shortcut to allow registering filter for all methods.
foreach method { GET POST HEAD PUT DELETE } {
foreach method { GET POST HEAD } {
ad_register_filter -debug $debug -priority $priority -critical $critical $kind $method $path $proc $arg
}
return
}
if {$method ni { GET POST HEAD PUT DELETE }} {
error "Method passed to ad_register_filter must be one of GET, POST, or HEAD PUT DELETE"
if {$method ni { GET POST HEAD }} {
error "Method passed to ad_register_filter must be one of GET, POST, or HEAD"
}
# Append the filter to the list. The list will be sorted according to priority
......@@ -453,7 +453,7 @@ ad_proc -private rp_html_directory_listing { dir } {
#
# NSV arrays used by the request processor:
#
# - rp_filters($method,$kind), where $method in (GET, POST, HEAD PUT DELETE)
# - rp_filters($method,$kind), where $method in (GET, POST, HEAD)
# and kind in (preauth, postauth, trace) A list of $kind filters
# to be considered for HTTP requests with method $method. The
# value is of the form
......@@ -461,7 +461,7 @@ ad_proc -private rp_html_directory_listing { dir } {
# [list $priority $kind $method $path $proc $args $debug \
# $critical $description $script]
#
# - rp_registered_procs($method), where $method in (GET, POST, HEAD PUT DELETE)
# - rp_registered_procs($method), where $method in (GET, POST, HEAD)
# A list of registered procs to be considered for HTTP requests with
# method $method. The value is of the form
#
......@@ -515,10 +515,11 @@ ad_proc -private rp_resources_filter { why } {
maximize throughput for resource files. We just ns_returnfile the file, no
permissions are checked, the ad_conn structure is not initialized, etc.
There are two mapping possibilities:
There are three mapping possibilities:
/resources/package-key/* maps to root/packages/package-key/www/resources/*
If that fails, we map to root/packages/acs-subsite/www/resources/*
If that fails, we map to root/www/resources/*
If the file doesn't exist we'll log an error and return filter_ok, which will allow
......@@ -534,12 +535,17 @@ ad_proc -private rp_resources_filter { why } {
return [rp_serve_resource_file $path]
}
set path "$::acs::rootdir/www/resources/[join [lrange [ns_conn urlv] 1 end] /]"
set path $::acs::rootdir/www/[ns_conn url]
if { [file isfile $path] } {
return [rp_serve_resource_file $path]
}
set path [acs_package_root_dir acs-subsite]/www/[ns_conn url]
if { [file isfile $path] } {
return [rp_serve_resource_file $path]
}
ns_log Error "rp_sources_filter: file \"$path\" does not exists trying to serve as a normal request"
ns_log Warning "rp_sources_filter: file \"$path\" does not exists trying to serve as a normal request"
return filter_ok
}
......@@ -775,13 +781,12 @@ ad_proc rp_report_error {
Writes an error to the connection.
@param message The message to write (pulled from <code>$errorInfo</code> if none is specified).
@param message The message to write (pulled from <code>$::errorInfo</code> if none is specified).
} {
if { ![info exists message] } {
global errorInfo
# We need 'message' to be a copy, because errorInfo will get overridden by some of the template parsing below
set message $errorInfo
# We need 'message' to be a copy, because errorInfo will get overridden by some of the template parsing below
set message $::errorInfo
}
set error_url "[ad_url][ad_conn url]?[export_entire_form_as_url_vars]"
# set error_file [template::util::url_to_file $error_url]
......@@ -827,9 +832,7 @@ ad_proc rp_report_error {
ns_return 500 text/html $rendered_page
set headers [ns_conn headers]
ns_log Error "[ns_conn method] http://[ns_set iget $headers host][ns_conn url]?[ns_conn query]\
referred by '$prev_url'\n$error_message"
ad_log error $error_message
}
ad_proc -private rp_path_prefixes {path} {
......@@ -1245,7 +1248,7 @@ ad_proc -public ad_acs_kernel_id {} {
ad_proc -public ad_conn {args} {
Returns a property about the connection. See the <a
href="/doc/request-processor.html">request
href="/doc/request-processor">request
processor documentation</a> for an (almost complete) list of allowable values.
<p>
......@@ -1520,7 +1523,7 @@ if { [apm_first_time_loading_p] } {
# since we want it done really really early in the startup process. Don't
# try this at home!
foreach method { GET POST HEAD PUT DELETE } { nsv_set rp_registered_procs $method [list] }
foreach method { GET POST HEAD } { nsv_set rp_registered_procs $method [list] }
}
......
tcl/security-init.tcl
View file @ 7b8caaf3
......@@ -39,3 +39,9 @@ proc sec_login_timeout {} "
return \"[parameter::get -package_id [ad_acs_kernel_id] -parameter LoginTimeout -default 28800]\"
"
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/security-procs.tcl
View file @ 7b8caaf3
......@@ -550,12 +550,13 @@ ad_proc -private ad_login_page {} {
Returns 1 if the page is used for logging in, 0 otherwise.
} {
set url [ad_conn url]
if { [string match "*register/*" $url] || [string match "/index*" $url] || \
[string match "/index*" $url] || \
"/" eq $url || \
[string match "*password-update*" $url] } {
if { [string match "*register/*" $url]
|| [string match "/index*" $url]
|| [string match "/index*" $url]
|| "/" eq $url
|| [string match "*password-update*" $url]
} {
return 1
}
......@@ -986,7 +987,7 @@ ad_proc -public ad_get_signed_cookie {
lassign $cookie_value value signature
ns_log Debug "ad_get_signed_cookie: Got signed cookie $name with value $value, signature $signature."
if { [ad_verify_signature $value $signature] } {
if { [ad_verify_signature -secret $secret $value $signature] } {
ns_log Debug "ad_get_signed_cookie: Verification of cookie $name OK"
return $value
}
......@@ -1016,7 +1017,7 @@ ad_proc -public ad_get_signed_cookie_with_expr {
}
lassign $cookie_value value signature
set expr_time [ad_verify_signature_with_expr $value $signature]
set expr_time [ad_verify_signature_with_expr -secret $secret $value $signature]
ns_log Debug "Security: Done calling get_cookie $cookie_value for $name; received $expr_time expiration, getting $value and $signature."
......@@ -1248,8 +1249,9 @@ ad_proc -private sec_lookup_property {
} {
Used as a helper procedure for util_memoize to look up a
particular property from the database. Returns
[list $property_value $secure_p].
particular property from the database.
@return empty, when no property is recorded or a list containing property_value and secure_p
} {
if {
......@@ -1287,7 +1289,7 @@ ad_proc -public ad_get_client_property {
Looks up a property for a session. If $cache is true, will use the
cached value if available. If $cache_only is true, will never
incur a database hit (i.e., will only return a value if
cached). If the property is secure, we must be on a validated session
cached). If the property is secure, we must be on a validated session
over SSL.
@param session_id controls which session is used
......@@ -1308,7 +1310,7 @@ ad_proc -public ad_get_client_property {
set cmd [list sec_lookup_property $id $module $name]
if { $cache_only == "t" && ![util_memoize_cached_p $cmd] } {
return ""
return $default
}
if { $cache != "t" } {
......@@ -1322,7 +1324,7 @@ ad_proc -public ad_get_client_property {
lassign $property value secure_p
if { $secure_p != "f" && ![security::secure_conn_p] } {
return ""
return $default
}
return $value
......@@ -1717,8 +1719,8 @@ ad_proc -public security::locations {} {
set host_post ""
# set host_name
if {![regexp {(http://|https://)(.*?):(.*?)/?} [util_current_location] discard host_protocol host_name host_port]} {
regexp {(http://|https://)(.*?)/?} [util_current_location] discard host_protocol host_name
if {![regexp {(http://|https://)(.*?):(.*?)/?} [util_current_location] . host_protocol host_name host_port]} {
regexp {(http://|https://)(.*?)/?} [util_current_location] . host_protocol host_name
}
set driver_section [ns_driversection -driver $driver]
......@@ -1727,7 +1729,7 @@ ad_proc -public security::locations {} {
# not same as from config.tcl, may help with proxy issues etc
set config_hostname [ns_config $driver_section hostname]
if { $config_hostname ne $host_name } {
ns_log Warning "security::locations hostname '[ns_config $driver_section hostname]' from config.tcl does not match from util_current_location: $host_name"
ns_log notice "security::locations hostname '[ns_config $driver_section hostname]' from config.tcl does not match from util_current_location: $host_name"
}
# insecure locations
......@@ -1785,7 +1787,7 @@ ad_proc -public security::locations {} {
get_node_host_names "select host from host_node_map"]
# fastest place for handling this special case:
if { $config_hostname ne $host_name } {
ns_log Notice "security::locations adding $config_hostname since utl_current_location different than config.tcl."
#ns_log Notice "security::locations adding $config_hostname since utl_current_location different than config.tcl."
lappend host_node_map_hosts_list $config_hostname
}
if { [llength $host_node_map_hosts_list] > 0 } {
......
tcl/server-cluster-procs.tcl
View file @ 7b8caaf3
......@@ -111,3 +111,9 @@ ad_proc -private ad_canonical_server_p {} {
return 0
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/set-operation-procs.tcl
View file @ 7b8caaf3
......@@ -143,3 +143,9 @@ ad_proc -deprecated set_difference! { u-name v } {
return $result
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/site-node-apm-integration-procs.tcl
View file @ 7b8caaf3
......@@ -72,3 +72,9 @@ namespace eval site_node_apm_integration {
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/site-node-object-map-procs.tcl
View file @ 7b8caaf3
......@@ -49,3 +49,9 @@ ad_proc -public site_node_object_map::get_url {
return [site_node::get_url -node_id $node_id]
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/site-nodes-init.tcl
View file @ 7b8caaf3
......@@ -9,3 +9,9 @@ ad_library {
nsv_set site_nodes_mutex mutex [ns_mutex create oacs:site_nodes]
site_node::init_cache
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/site-nodes-procs.tcl
View file @ 7b8caaf3
This diff is collapsed.
tcl/sql-statement-procs.tcl
View file @ 7b8caaf3
......@@ -85,3 +85,9 @@ ad_proc -public ad_sql_append {
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/stack-trace-procs.tcl
View file @ 7b8caaf3
......@@ -21,9 +21,8 @@ ad_proc -public ad_print_stack_trace {} {
@see ad_get_tcl_call_stack
} {
uplevel {
global errorInfo
if {$errorInfo ne ""} {
set callStack [list $errorInfo "invoked from within"]
if {$::errorInfo ne ""} {
set callStack [list $::errorInfo "invoked from within"]
} else {
set callStack {}
}
......@@ -46,3 +45,9 @@ ad_proc -public ad_log_stack_trace {} {
} {
ns_log Error [ad_print_stack_trace]
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/table-display-procs.tcl
View file @ 7b8caaf3
......@@ -4,160 +4,10 @@ ad_library {
@cvs-id $Id$
}
# Dimensional selection bars.
#
ad_proc ad_dimensional {
option_list
{url {}}
{options_set ""}
{optionstype url}
} {
Generate an option bar as in the ticket system;
<ul>
<li> option_list -- the structure with the option data provided
<li> url -- url target for select (if blank we set it to ad_conn url).
<li> options_set -- if not provided defaults to [ns_getform], for hilite of selected options.
<li> optionstype -- only url is used now, was thinking about extending
so we get radio buttons and a form since with a slow select updating one
thing at a time would be stupid.
</ul>
<p>
option_list structure is
<pre>
{
{variable "Title" defaultvalue
{
{value "Text" {key clause}}
...
}
}
...
}
an example:
set dimensional_list {
{visited "Last Visit" 1w {
{never "Never" {where "last_visit is null"}}
{1m "Last Month" {where "last_visit + 30 > sysdate"}}
{1w "Last Week" {where "last_visit + 7 > sysdate"}}
{1d "Today" {where "last_visit > trunc(sysdate)"}}
}}
..(more of the same)..
}
</pre>
} {
set html {}
if {$option_list eq ""} {
return
}
if {$options_set eq ""} {
set options_set [ns_getform]
}
if {$url eq ""} {
set url [ad_conn url]
}
append html "<table border=\"0\" cellspacing=\"0\" cellpadding=\"3\" width=\"100%\">\n<tr>\n"
foreach option $option_list {
append html " <th style=\"background-color: #ECECEC\">[lindex $option 1]</th>\n"
}
append html "</tr>\n"
append html "<tr>\n"
foreach option $option_list {
append html " <td align='center'>\["
# find out what the current option value is.
# check if a default is set otherwise the first value is used
set option_key [lindex $option 0]
set option_val {}
if { $options_set ne ""} {
set option_val [ns_set get $options_set $option_key]
}
if { $option_val eq "" } {
set option_val [lindex $option 2]
}
set first_p 1
foreach option_value [lindex $option 3] {
set thisoption [lindex $option_value 0]
if { $first_p } {
set first_p 0
} else {
append html " | "
}
if {$option_val eq $thisoption } {
append html "<strong>[ns_quotehtml [lindex $option_value 1]]</strong>"
} else {
set href $url?[export_ns_set_vars url $option_key $options_set]&[ns_urlencode $option_key]=[ns_urlencode $thisoption]
append html [subst {<a href="[ns_quotehtml $href]">[ns_quotehtml [lindex $option_value 1]]</a>}]
}
}
append html "\]</td>\n"
}
append html "</tr>\n</table>\n"
}
ad_proc ad_dimensional_sql {
option_list
{what "where"}
{joiner "and"}
{options_set ""}
} {
see ad_dimensional for the format of option_list
<p>
Given what clause we are asking for and the joiner this returns
the sql fragment
} {
set out {}
if {$option_list eq ""} {
return
}
if {$options_set eq ""} {
set options_set [ns_getform]
}
foreach option $option_list {
# find out what the current option value is.
# check if a default is set otherwise the first value is used
set option_key [lindex $option 0]
set option_val {}
# get the option from the form
if { $options_set ne ""} {
set option_val [ns_set get $options_set $option_key]
}
#otherwise get from default
if { $option_val eq "" } {
set option_val [lindex $option 2]
}
foreach option_value [lindex $option 3] {
set thisoption [lindex $option_value 0]
if {$option_val eq $thisoption } {
set code [lindex $option_value 2]
if {$code ne ""} {
if {[lindex $code 0] eq $what } {
append out " $joiner [uplevel [list subst [lindex $code 1]]]"
}
}
}
}
}
return $out
}
ad_proc ad_dimensional_set_variables {option_list {options_set ""}} {
ad_proc -deprecated ad_dimensional_set_variables {option_list {options_set ""}} {
set the variables defined in option_list from the form provided
(form defaults to ad_conn form) or to default value from option_list if
not in the form data.
......@@ -815,7 +665,7 @@ ad_proc -deprecated ad_table_sort_form {
return $html
}
ad_proc ad_order_by_from_sort_spec {sort_by tabledef} {
ad_proc -deprecated ad_order_by_from_sort_spec {sort_by tabledef} {
Takes a sort_by spec, and translates it into into an "order by" clause
with each sort_by key dictated by the sort info in tabledef
} {
......@@ -883,7 +733,7 @@ ad_proc -deprecated ad_new_sort_by {key keys} {
}
}
ad_proc ad_same_page_link {variable value text {form ""}} {
ad_proc -deprecated ad_same_page_link {variable value text {form ""}} {
Makes a link to this page, with a new value for "variable".
} {
if { $form eq "" } {
......@@ -894,7 +744,7 @@ ad_proc ad_same_page_link {variable value text {form ""}} {
return [subst {<a href="[ns_quotehtml $href]">[ns_quotehtml $text]</a>}]
}
ad_proc ad_reverse order {
ad_proc -deprecated ad_reverse order {
returns the opposite sort order from the
one it is given. Mostly for columns whose natural
sort order is not the default.
......@@ -906,7 +756,7 @@ ad_proc ad_reverse order {
return $order
}
ad_proc ad_custom_load {user_id item_group item item_type} {
ad_proc -deprecated ad_custom_load {user_id item_group item item_type} {
load a persisted user customization as saved by
for example table-custom.tcl.
} {
......@@ -926,7 +776,7 @@ ad_proc ad_custom_load {user_id item_group item item_type} {
return $value
}
ad_proc ad_custom_list {user_id item_group item_set item_type target_url custom_url {new_string "new view"}} {
ad_proc -deprecated ad_custom_list {user_id item_group item_set item_type target_url custom_url {new_string "new view"}} {
Generates the html fragment for choosing, editing and creating
user customized data
} {
......@@ -953,7 +803,7 @@ ad_proc ad_custom_list {user_id item_group item_set item_type target_url custom_
}
ad_proc ad_custom_page_defaults {defaults} {
ad_proc -deprecated ad_custom_page_defaults {defaults} {
set the page defaults. If the form is
empty do a returnredirect with the defaults set
} {
......@@ -981,7 +831,7 @@ ad_proc ad_custom_page_defaults {defaults} {
}
}
ad_proc ad_custom_form {return_url item_group item} {
ad_proc -deprecated ad_custom_form {return_url item_group item} {
sets up the head of a form to feed to /tools/form-custom.tcl
} {
append html "<form method=\"get\" action=\"/tools/form-custom\">\n"
......@@ -996,7 +846,7 @@ ad_proc ad_custom_form {return_url item_group item} {
append html "<input type=\"submit\" value=\"Save settings\">"
}
ad_proc ad_dimensional_settings {define current} {
ad_proc -deprecated ad_dimensional_settings {define current} {
given a dimensional slider definition this routine returns a form to set the
defaults for the given slider.
......@@ -1014,9 +864,9 @@ ad_proc ad_dimensional_settings {define current} {
}
foreach val [lindex $opt 3] {
if {$picked eq [lindex $val 0] } {
append html "<option selected=\"selected\" value=\"[ad_quotehtml [lindex $val 0]]\">[lindex $val 1]</option>\n"
append html "<option selected=\"selected\" value=\"[ns_quotehtml [lindex $val 0]]\">[lindex $val 1]</option>\n"
} else {
append html "<option value=\"[ad_quotehtml [lindex $val 0]]\">[lindex $val 1]</option>\n"
append html "<option value=\"[ns_quotehtml [lindex $val 0]]\">[lindex $val 1]</option>\n"
}
}
append html "</select></td></tr>\n"
......@@ -1039,3 +889,9 @@ ad_proc -deprecated ad_table_orderby_sql {datadef orderby order} {
return $orderclause
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/tcl-documentation-procs.tcl
View file @ 7b8caaf3
This diff is collapsed.
tcl/tcltrace-init.tcl
View file @ 7b8caaf3
......@@ -10,8 +10,8 @@
#
set trace ""
foreach {parameter default cmd} {
TclTraceLogServerities "" {trace add execution ::ns_log enter {::tcltrace::before-ns_log}}
TclTraceSaveNsReturn 0 {trace add execution ::ns_return enter {::tcltrace::before-ns_return}}
TclTraceLogServerities "" {trace add execution ::ns_log enter {::tcltrace::before-ns_log}}
TclTraceSaveNsReturn 0 {trace add execution ::ns_return enter {::tcltrace::before-ns_return}}
} {
if {[::parameter::get_from_package_key \
-package_key acs-tcl \
......@@ -20,7 +20,19 @@ foreach {parameter default cmd} {
append trace \n$cmd
}
}
#
# Optionally add more traces here
#
#append trace "\ntrace add execution ::nsv_get enter {::tcltrace::before}"
if {$trace ne ""} {
ns_ictl trace create $trace
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/tcltrace-procs.tcl
View file @ 7b8caaf3
......@@ -65,10 +65,23 @@ namespace eval ::tcltrace {
} else {
#catch {ds_comment "ignore $severity $msg"}
}
}
}
ad_proc -private before { cmd op } {
Simple trace proc for arbitraty commands. simply reports traces to error.log.
} {
ns_log notice $cmd
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/tdom-procs.tcl
View file @ 7b8caaf3
......@@ -116,4 +116,9 @@ ad_proc -public tdom::get_node_xml {
catch {set node_xml [$node_object asXML]}
return [string trim $node_xml]
}
\ No newline at end of file
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/acs-tcl-apm-procs.tcl
View file @ 7b8caaf3
......@@ -71,3 +71,9 @@ aa_register_case -cats {api smoke} -procs {apm_package_instance_new} test_apm_pa
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/acs-tcl-test-procs.tcl
View file @ 7b8caaf3
......@@ -123,8 +123,7 @@ aa_register_case -cats {api db smoke} apm__test_info_file {
if { $error_p } {
global errorInfo
error "$error - $errorInfo"
error "$error - $::errorInfo"
}
}
......@@ -163,8 +162,7 @@ aa_register_case -cats {api db smoke} apm__test_callback_get_set {
apm_remove_callback_proc -package_key $package_key -type $callback_type
if { $error_p } {
global errorInfo
error "$error - $errorInfo"
error "$error - $::errorInfo"
}
}
......@@ -200,8 +198,7 @@ aa_register_case -cats {db api smoke} apm__test_callback_invoke {
apm_remove_callback_proc -package_key $package_key -type $type
if { $error_p } {
global errorInfo
error "$error - $errorInfo"
error "$error - $::errorInfo"
}
}
......@@ -304,9 +301,8 @@ aa_register_case -cats {api smoke} text_to_html {
set errno [catch { set text_version [ad_html_to_text -- $offending_post] } errmsg]
if { ![aa_equals "Does not bomb" $errno 0] } {
global errorInfo
aa_log "errmsg: $errmsg"
aa_log "errorInfo: $errorInfo"
aa_log "errmsg: $errmsg"
aa_log "errorInfo: $::errorInfo"
} else {
aa_equals "Expected identical result" $text_version $offending_post
}
......@@ -368,9 +364,8 @@ anybody have any ideas?
set errno [catch { set text_version [ad_html_to_text -- $offending_post] } errmsg]
if { ![aa_equals "Does not bomb" $errno 0] } {
global errorInfo
aa_log "errmsg: $errmsg"
aa_log "errorInfo: $errorInfo"
aa_log "errorInfo: $::errorInfo"
} else {
aa_log "Text version: $text_version"
}
......@@ -1019,7 +1014,12 @@ aa_register_case -cats {api db} db__caching {
aa_register_case \
-cats {api smoke} \
-procs {parameter::get parameter::get_from_package_key parameter::set_default parameter::set_default parameter::set_value parameter::set_from_package_key parameter::set_global_value parameter::get_global_value} \
-procs {
parameter::get parameter::get_from_package_key
parameter::set_default parameter::set_default
parameter::set_value parameter::set_from_package_key
parameter::set_global_value parameter::get_global_value
} \
parameter__check_procs {
Test the parameter::* procs
......@@ -1036,7 +1036,7 @@ aa_register_case \
apm_parameter_register -parameter_id $parameter_id -scope global x_test_x "" acs-tcl 0 number
parameter::set_global_value -package_key acs-tcl -parameter x_test_x -value 3
aa_equals "check global parameter value set/get" \
[parameter::get_global_value -package_key acs-tcl -parameter x_test_x]\
[parameter::get_global_value -package_key acs-tcl -parameter x_test_x] \
"3"
apm_parameter_unregister $parameter_id
......@@ -1046,18 +1046,17 @@ aa_register_case \
where
ap.package_key = apt.package_key
and apt.singleton_p ='t'
and ap.package_key <> 'acs-kernel'
and ap.package_key <> 'acs-kernel' and ap.package_key <> 'search'
}] {
lassign $tuple parameter_name package_key default_value parameter_id
set value [random]
if {$parameter_name ne "PasswordExpirationDays" && $value > 0.7} {
set package_id [apm_package_id_from_key $package_key]
set package_id [apm_package_id_from_key $package_key]
set actual_value [db_string real_value {
select apm_parameter_values.attr_value
from
apm_parameter_values
from apm_parameter_values
where apm_parameter_values.package_id = :package_id
and apm_parameter_values.parameter_id = :parameter_id
}]
......@@ -1133,3 +1132,9 @@ aa_register_case -cats {api smoke} acs_user__registered_user_p {
aa_true "registered_user_p works correct" $works_p
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/ad-proc-test-procs.tcl
View file @ 7b8caaf3
......@@ -142,3 +142,9 @@ aa_register_case -cats {api smoke} ad_proc_fire_callback {
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/apm-parameter-test-procs.tcl
View file @ 7b8caaf3
......@@ -29,3 +29,9 @@ aa_register_case -cats {api smoke} parameter_register_test {
aa_log "Unregistering an global parameter"
apm_parameter_unregister $parameter_id
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/application-data-link-procs.tcl
View file @ 7b8caaf3
......@@ -237,4 +237,9 @@ aa_register_case -cats api data_links_with_tag {
[expr {[llength [application_data_link::get -object_id $o(0) -relation_tag tag2]] == 1}]
}
}
\ No newline at end of file
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/community-core-test-procs.tcl
View file @ 7b8caaf3
......@@ -133,3 +133,9 @@ aa_register_case \
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/datamodel-test-procs.tcl
View file @ 7b8caaf3
......@@ -219,3 +219,9 @@ aa_register_case -cats {db smoke production_safe} datamodel__acs_attribute_check
}
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/doc-check-procs.tcl
View file @ 7b8caaf3
......@@ -54,3 +54,9 @@ aa_register_case -cats {smoke production_safe} -error_level warning documentatio
aa_log "Found $good of $count procs checked"
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/file-test-procs.tcl
View file @ 7b8caaf3
......@@ -217,7 +217,7 @@ aa_register_case -cats {smoke} files__check_xql_files {
if { [catch {set parse [xml_parse $data]} errMsg] } {
ns_log warning "acs_tcl__check_xql_files: failed parse $file $errMsg"
aa_log_result fail "XML Parse Error: $file [ad_quotehtml $errMsg]"
aa_log_result fail "XML Parse Error: $file [ns_quotehtml $errMsg]"
} else {
# lets walk the nodes and check they are what we want to see.
......@@ -301,3 +301,9 @@ aa_register_case -cats {smoke} files__check_xql_files {
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/html-conversion-procs.tcl
View file @ 7b8caaf3
......@@ -191,10 +191,10 @@ aa_register_case -cats {api smoke} -procs {ad_quotehtml ad_unquotehtml} quote_un
Test if it quote and unquote html
} {
#quote html
set html "\"<&text>\""
set html {"<&text>"}
aa_log "Unquote html=$html"
set result [ad_quotehtml $html]
aa_true "Quoute html=$result" [string equal "&quot;&lt;&amp;text&gt;&quot;" $result]
set result [ns_quotehtml $html]
aa_true "Quoute html=$result" [string equal "&#34;&lt;&amp;text&gt;&#34;" $result]
#unquote html
set html $result
......@@ -297,3 +297,9 @@ aa_register_case -cats {api smoke} -procs {ad_html_text_convert} ad_text_html_co
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/html-email-procs.tcl
View file @ 7b8caaf3
......@@ -14,4 +14,9 @@ aa_register_case -cats {api smoke} build_mime_message {
[catch {package require mime} errmsg]
}
\ No newline at end of file
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/log-test-procs.tcl
View file @ 7b8caaf3
......@@ -41,3 +41,9 @@ aa_register_case -cats {smoke} -error_level warning server_error_log {
close $fd
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/memoizing-procs.tcl
View file @ 7b8caaf3
......@@ -51,3 +51,9 @@ aa_register_case -cats {api smoke} ad_proc_flush {
aa_equals "proc was flushed succesful" $success_p 0
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/multirow-test.tcl
View file @ 7b8caaf3
......@@ -7,3 +7,9 @@ ad_page_contract {
}
ad_context_bar_multirow -multirow test_rows -from_node $from_node -node_id $node_id $context
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/navigation-procs.tcl
View file @ 7b8caaf3
......@@ -200,3 +200,9 @@ aa_register_case -cats {
set response_body [::tclwebtest::response body]
aa_equals "Context bar $context_barp" $response_body $context_barp
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/object-test-case-procs.tcl
View file @ 7b8caaf3
......@@ -133,3 +133,9 @@ aa_register_case \
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/openacs-kernel-procs.tcl
View file @ 7b8caaf3
......@@ -72,3 +72,9 @@ aa_register_case -cats {api smoke} -procs {oacs_util::process_objects_csv} proce
file delete -force $file_loc
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/site-nodes-test-procs.tcl
View file @ 7b8caaf3
......@@ -148,3 +148,9 @@ aa_register_case -cats {
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/test-membership-rel-procs.tcl
View file @ 7b8caaf3
......@@ -70,4 +70,9 @@ aa_register_case -cats {api smoke} ad_proc_change_state_member {
}
}
\ No newline at end of file
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/test-permissions-procs.tcl
View file @ 7b8caaf3
......@@ -123,4 +123,9 @@ aa_register_case -cats {api smoke} ad_proc_permission_permission_p {
[expr {[permission::permission_p -party_id $user_id -object_id $new_package_id -privilege "admin" ] == 1}]
permission::revoke -party_id $user_id -object_id $new_package_id -privilege "admin"
}
}
\ No newline at end of file
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/test-set-cookie-procs.tcl
View file @ 7b8caaf3
......@@ -85,4 +85,9 @@ aa_register_case \
aa_equals "Obtain client property" MyValue [ad_get_client_property test MyName]
}
}
\ No newline at end of file
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/test/whos-online-procs.tcl
View file @ 7b8caaf3
......@@ -78,3 +78,9 @@ aa_register_case -cats {
}
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/text-html-procs.tcl
View file @ 7b8caaf3
......@@ -76,7 +76,7 @@ ad_proc -public ad_text_to_html {
# At this point, before inserting some of our own <, >, and "'s
# we quote the ones entered by the user:
if { !$no_quote_p } {
set text [ad_quotehtml $text]
set text [ns_quotehtml $text]
}
if { $encode_p} {
......@@ -100,9 +100,11 @@ ad_proc -public ad_text_to_html {
&uuml; &yacute; &thorn; &yuml; &iquest;
}
for { set i 0 } { $i < [ llength $myChars ] } { incr i } {
set text [ string map "[ lindex $myChars $i ] [ lindex $myHTML $i ]" $text ]
set map {}
foreach ch $myChars entity $myHTML {
lappend map $ch $entity
}
set text [string map $map $text]
}
# Convert line breaks
......@@ -200,7 +202,7 @@ ad_proc -public ad_unquotehtml {arg} {
@see ad_quotehtml
} {
return [string map {&gt; > &lt; < &quot; \" &amp; &} $arg]
return [string map {&amp; & &gt; > &lt; < &quot; \" &#34; \" &#39; '} $arg]
}
......@@ -210,12 +212,12 @@ ad_proc -public ad_unquotehtml {arg} {
#
####################
#
# lars@pinds.com, 19 July 2000:
# Should this proc change name to something in line with the rest
# of the library?
#
ad_proc -private util_close_html_tags {
html_fragment
{break_soft 0}
......@@ -255,8 +257,6 @@ ad_proc -private util_close_html_tags {
@author Jeff Davis (davis@xarg.net)
} {
set frag $html_fragment
#
# The code in this function had an exponential behavior based on
# the size. On the current OpenACS.org site (Jan 2009), the
......@@ -285,22 +285,28 @@ ad_proc -private util_close_html_tags {
# -gustaf neumann (Jan 2009)
if {$break_soft == 0 && $break_hard == 0} {
set frag [string map [list &# "&amp;#"] $html_fragment]
if {[catch {dom parse -html <body>$frag doc} errorMsg]} {
# we got an error, so do normal processing
#ns_log notice "tdom can't parse the provided HTML, error=$errorMsg,\nchecking fragment without tdom"
} else {
$doc documentElement root
set html ""
# discared forms
foreach node [$root selectNodes //form] {$node delete}
# output wellformed html
set b [lindex [$root selectNodes {//body}] 0]
foreach n [$b childNodes] {
append html [$n asHTML]
#
# We have to protect against crashes, that might happen due to
# unsupported numeric entities in tdom. Therefore, we map
# numeric entities into something sufficiently opaque
#
set frag [string map [list &# "\0&amp;#\0"] $html_fragment]
if {[catch {dom parse -html <body>$frag doc} errorMsg]} {
# we got an error, so do normal processing
ns_log notice "tdom can't parse the provided HTML, error=$errorMsg,\nchecking fragment without tdom"
} else {
$doc documentElement root
set html ""
# discard forms
foreach node [$root selectNodes //form] {$node delete}
# output wellformed html
set b [lindex [$root selectNodes {//body}] 0]
foreach n [$b childNodes] {
append html [$n asHTML]
}
return [string map [list "\0&amp;#\0" &#] $html]
}
return $html
}
}
set frag $html_fragment
......@@ -1102,12 +1108,12 @@ ad_proc -public ad_html_to_text {
&uuml; &yacute; &thorn; &yuml; &iquest;
}
for { set i 0 } { $i < [ llength $myHTML ] } { incr i } {
set output(text) [ string map "[ lindex $myHTML $i ] [ lindex $myChars $i ]" $output(text) ]
set map {}
foreach ch $myChars entity $myHTML {
lappend map $entity $ch
}
#---
return $output(text)
return [string map $map $output(text)]
}
ad_proc -private ad_html_to_text_put_newline { output_var } {
......@@ -1552,7 +1558,7 @@ ad_proc -public ad_html_text_convert {
set text [string_truncate -ellipsis $ellipsis -more $more -len $truncate_len -- $text]
}
}
return $text
}
......@@ -1778,7 +1784,7 @@ ad_proc -deprecated -warn util_quotehtml { arg } {
@see ad_quotehtml
} {
return [ad_quotehtml $arg]
return [ns_quotehtml $arg]
}
ad_proc -deprecated util_quote_double_quotes {arg} {
......@@ -1787,7 +1793,7 @@ ad_proc -deprecated util_quote_double_quotes {arg} {
@see ad_quotehtml
} {
return [ad_quotehtml $arg]
return [ns_quotehtml $arg]
}
ad_proc -deprecated philg_quote_double_quotes {arg} {
......@@ -1796,5 +1802,11 @@ ad_proc -deprecated philg_quote_double_quotes {arg} {
@see ad_quotehtml
} {
return [ad_quotehtml $arg]
return [ns_quotehtml $arg]
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/user-extensions-procs.tcl
View file @ 7b8caaf3
......@@ -94,3 +94,9 @@ namespace eval acs_user_extension {
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/util-diff-procs.tcl
View file @ 7b8caaf3
......@@ -189,11 +189,11 @@ ad_proc -public util::html_diff {
}
if { $action eq "changed" } {
if {$show_old_p} {
ns_log notice "adding <@d@>"
#ns_log notice "adding <@d@>"
lappend output <@d@>
foreach item [lrange $old_list $old_index1 $old_index2] {
if {![string match "<*>" [string trim $item]]} {
ns_log notice "deleting item '${item}'"
#ns_log notice "deleting item '${item}'"
# showing deleted tags is a bad idea.
lappend output [string trim $item]
} else {
......@@ -201,21 +201,21 @@ ad_proc -public util::html_diff {
}
}
ns_log notice "adding </@d@>"
#ns_log notice "adding </@d@>"
lappend output </@d@>
}
ns_log notice "adding <@a@>"
#ns_log notice "adding <@a@>"
lappend output <@a@>
foreach item [lrange $new_list $new_index1 $new_index2] {
if {![string match "<*>" [string trim $item]]} {
ns_log notice "adding item '${item}'"
#ns_log notice "adding item '${item}'"
lappend output [string trim $item]
} else {
lappend output </@a@>${item}<@a@>
ns_log notice "adding</@a@>${item}<@a@>"
#ns_log notice "adding</@a@>${item}<@a@>"
}
}
ns_log notice "adding </@a@>"
#ns_log notice "adding </@a@>"
lappend output </@a@>
incr i [expr {$old_index2 - $old_index1 + 1}]
} elseif { $action eq "deleted" } {
......@@ -227,14 +227,14 @@ ad_proc -public util::html_diff {
incr i [expr {$old_index2 - $old_index1 + 1}]
} elseif { $action eq "added" } {
while {$i < $old_index2} {
ns_log notice "unchanged item"
lappend output [lindex $old_list $i]
#ns_log notice "unchanged item"
lappend output [lindex $old_list $i]
incr i
}
lappend output <@a@>
foreach item [lrange $new_list $new_index1 $new_index2] {
if {![string match "<*>" [string trim $item]]} {
ns_log notice "adding item"
#ns_log notice "adding item"
lappend output [string trim $item]
}
}
......@@ -256,3 +256,9 @@ ad_proc -public util::html_diff {
return "$output"
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/utilities-init.tcl
View file @ 7b8caaf3
......@@ -20,3 +20,9 @@ if { $logmaxbackup } {
ad_schedule_proc -all_servers t -schedule_proc ns_schedule_daily \
[list 00 00] util::roll_server_log
}
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/utilities-procs.tcl
View file @ 7b8caaf3
This diff is collapsed.
tcl/whos-online-init.tcl
View file @ 7b8caaf3
......@@ -8,3 +8,9 @@ ad_library {
# Schedule proc to clean up whos_online data structure
whos_online::init
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
tcl/whos-online-procs.tcl
View file @ 7b8caaf3
This diff is collapsed.
tcl/widgets-procs.tcl
View file @ 7b8caaf3
This diff is collapsed.
tcl/xml-0-sgml-procs.tcl
View file @ 7b8caaf3
This diff is collapsed.
tcl/xml-1-dom-procs.tcl
View file @ 7b8caaf3
This diff is collapsed.
tcl/xml-2-procs.tcl
View file @ 7b8caaf3
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment