Skip to content

A
acs-bootstrap-installer
Commit 8aa63e47 authored by Frank Bergmann's avatar Frank Bergmann
Browse files
Options

- Comitting OpenACS 5.9

parent b16bf171
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 560 additions and 438 deletions
acs-bootstrap-installer.info
View file @ 8aa63e47
......@@ -6,29 +6,27 @@
<pretty-plural>Bootstrap Installers</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.7.0" url="http://openacs.org/repository/download/apm/acs-bootstrap-installer-5.7.0.apm">
<version name="5.10.0d1" url="http://openacs.org/repository/download/apm/acs-bootstrap-installer-5.10.0d1.apm">
<owner url="mailto:dhogaza@pacifier.com">Don Baccus</owner>
<summary>Bootstraps an OpenACS installation.</summary>
<release-date>2011-06-12</release-date>
<maturity>3</maturity>
<release-date>2013-09-08</release-date>
<vendor url="http://openacs.org">OpenACS</vendor>
<license url="http://www.gnu.org/copyleft/gpl.html">GPL</license>
<maturity>3</maturity>
<description format="text/html">This package bootstraps OpenACS. If the core packages have not yet been installed, it calls the installer which leads the user through the steps necessary to do so. It also checks that the installation meets the requirements for a successful install of OpenACS.</description>
<license>GPL</license>
<maturity>3</maturity>
<provides url="acs-bootstrap-installer" version="5.7.0"/>
<requires url="acs-kernel" version="5.7.0"/>
<provides url="acs-bootstrap-installer" version="5.10.0d1"/>
<requires url="acs-kernel" version="5.10.0d1"/>
<callbacks>
<callback type="after-upgrade" proc="apm_bootstrap_upgrade"/>
</callbacks>
<parameters>
<parameter datatype="string" min_n_values="1" max_n_values="1" name="post_installation_message" default="" description="If not blank, overrides the default post-installation message" section_name="installation"/>
<parameter scope="instance" datatype="string" min_n_values="1" max_n_values="1" name="post_installation_message" description="If not blank, overrides the default post-installation message" section_name="installation"/>
</parameters>
</version>
</package>
bootstrap.tcl
View file @ 8aa63e47
......@@ -6,6 +6,11 @@
# @author Jon Salz [jsalz@arsdigita.com]
# @cvs-id $Id$
if {![info exists ::acs::rootdir]} {
# just a temporary measure before the release of OpenACS 5.8.1
ns_log warning "update openacs-4/tcl/0-acs-init.tcl"
set ::acs::rootdir [file dirname [string trimright $::acs::tcllib "/"]]
}
# Remember the length of the error log file (so we can easily seek back to this
# point later). This is used in /www/admin/monitoring/startup-log.tcl to show
......@@ -19,6 +24,8 @@ nsv_set proc_source_file . ""
# Initialize ad_after_server_initialization.
nsv_set ad_after_server_initialization . ""
ns_log Notice "bootstrap begin encoding [encoding system]"
###
#
# Bootstrapping code.
......@@ -33,14 +40,13 @@ proc bootstrap_fatal_error { message { throw_error_p 1 } } {
proc rp_invoke_procs { conn arg why } {}
set proc_name {Bootstrap}
global errorInfo
# Save the error message.
nsv_set bootstrap_fatal_error . "$message<blockquote><pre>[ns_quotehtml $errorInfo]</pre></blockquote>"
nsv_set bootstrap_fatal_error . "$message<blockquote><pre>[ns_quotehtml $::errorInfo]</pre></blockquote>"
# Log the error message.
ns_log Error "$proc_name: Server startup failed: $message\n$errorInfo"
ns_log Error "$proc_name: Server startup failed: $message\n$::errorInfo"
# Define a filter procedure which displays the appropriate error message.
proc bootstrap_write_error { conn arg why } {
proc bootstrap_write_error { args } {
ns_returnerror 503 "Server startup failed: [nsv_get bootstrap_fatal_error .]"
return "filter_return"
}
......@@ -61,9 +67,9 @@ set errno [catch {
# Load the special bootstrap tcl library.
set files [glob -nocomplain "$root_directory/packages/acs-bootstrap-installer/tcl/*-procs.tcl"]
set files [lsort [glob -nocomplain "$::acs::rootdir/packages/acs-bootstrap-installer/tcl/*-procs.tcl"]]
if { [llength $files] == 0 } {
error "Unable to locate $root_directory/packages/acs-bootstrap-installer/tcl/*-procs.tcl."
error "Unable to locate $::acs::rootdir/packages/acs-bootstrap-installer/tcl/*-procs.tcl."
}
foreach file [lsort $files] {
......@@ -84,7 +90,7 @@ set errno [catch {
# gauntlet thus far.
if { ![info exists database_problem] } {
set db_fn "$root_directory/packages/acs-bootstrap-installer/db-init-checks-[nsv_get ad_database_type .].tcl"
set db_fn "$::acs::rootdir/packages/acs-bootstrap-installer/db-init-checks-[nsv_get ad_database_type .].tcl"
if { ![file isfile $db_fn] } {
set database_problem "\"$db_fn\" does not exist."
} else {
......@@ -102,17 +108,17 @@ set errno [catch {
# Check if the admin enabled the site-failure message, display
# it if enabled.
if { [file exists "$root_directory/www/global/site-failure.html"] } {
if { [file exists "$::acs::rootdir/www/global/site-failure.html"] } {
ns_log Notice "$proc_name: database problem found; enabling www/global/site-failure.html. Rename this html page if you want to run the installer instead."
source "$root_directory/packages/acs-bootstrap-installer/site-failure-message.tcl"
source "$::acs::rootdir/packages/acs-bootstrap-installer/site-failure-message.tcl"
return
}
# Remember what the problem is, and run the installer.
nsv_set acs_properties database_problem $database_problem
ns_log Notice "$proc_name: database problem found; Sourcing the installer."
source "$root_directory/packages/acs-bootstrap-installer/installer.tcl"
source "$root_directory/packages/acs-bootstrap-installer/installer-init.tcl"
source "$::acs::rootdir/packages/acs-bootstrap-installer/installer.tcl"
source "$::acs::rootdir/packages/acs-bootstrap-installer/installer-init.tcl"
return
}
......@@ -125,8 +131,8 @@ set errno [catch {
# Is OpenACS installation complete? If not, source the installer and bail.
if { ![ad_verify_install] } {
ns_log Notice "$proc_name: Installation is not complete - sourcing the installer."
source "$root_directory/packages/acs-bootstrap-installer/installer.tcl"
source "$root_directory/packages/acs-bootstrap-installer/installer-init.tcl"
source "$::acs::rootdir/packages/acs-bootstrap-installer/installer.tcl"
source "$::acs::rootdir/packages/acs-bootstrap-installer/installer-init.tcl"
return
}
......@@ -140,16 +146,12 @@ set errno [catch {
ns_log Notice "Loading acs-automated-testing specially so other packages can define tests..."
apm_bootstrap_load_libraries -procs acs-automated-testing
# GN: Should be loaded before user packages such they can use
# the xotcl infrastructure
# DRB: only do it if xotcl's installed
# Package libraries are now loaded in dependency order, rather than
# alphabetically. This code is obsolete and has been commented out
# for 5.7.
#if {[info command ::xotcl::Class] ne "" &&
# [file isdirectory $root_directory/packages/xotcl-core]} {
#if {[info commands ::xotcl::Class] ne "" &&
# [file isdirectory $::acs::rootdir/packages/xotcl-core]} {
# apm_bootstrap_load_libraries -procs xotcl-core
# apm_bootstrap_load_libraries -init xotcl-core
#}
......@@ -175,7 +177,7 @@ set errno [catch {
bootstrap_fatal_error "The request processor routines have not been loaded."
}
ns_log Notice "bootstrap finished encoding [encoding system]"
ns_log Notice "$proc_name: Done loading OpenACS."
}]
......@@ -187,8 +189,7 @@ if { $errno && $errno != 2 } {
# If the $errorCode is "bootstrap_fatal_error", then the error was explicitly
# thrown by a call to bootstrap_fatal_error. If not, bootstrap_fatal_error was
# never called, so we need to call it now.
global errorCode
if {$errorCode ne "bootstrap_fatal_error" } {
if {$::errorCode ne "bootstrap_fatal_error" } {
bootstrap_fatal_error "Error during bootstrapping" 0
}
}
db-init-checks-postgresql.tcl
View file @ 8aa63e47
......@@ -47,7 +47,7 @@ proc db_bootstrap_checks { errors error_p } {
## Make sure the __test__() function is dropped if it exists
if {![empty_string_p [ns_db 0or1row $db "select proname from pg_proc where proname = '__test__' and pronargs = 0"]]} {
if {[ns_db 0or1row $db "select proname from pg_proc where proname = '__test__' and pronargs = 0"] ne ""} {
catch { ns_db dml $db "drop function __test__();" }
}
......
installer.tcl
View file @ 8aa63e47
This diff is collapsed.
installer/index.tcl
View file @ 8aa63e47
......@@ -41,10 +41,9 @@ The installation program has encounted an error. Please drop your OpenACS table
and the OpenACS username, recreate them, and try again. You can log this as a bug
using the <a href=\"http://openacs.org/bugtracker/openacs\">OpenACS Bug Tracker</a>.
"
return
return
}
return
}
set body "
......@@ -78,10 +77,10 @@ application after the basic OpenACS tookit has been installed.
"
if { $acs_application(home) ne "" } {
append body "<p>
append body [subst {<p>
For more information about the $acs_application(pretty_name) application visit the
<a href=\"$acs_application(home)\">$acs_application(pretty_name) home page</a>
"
<a href="[ns_quotehtml $acs_application(home)]">$acs_application(pretty_name) home page</a>
}
}
} else {
set acs_application(name) openacs
......@@ -125,44 +124,24 @@ if { !$error_p } {
if { [catch { ns_sha1 quixotusishardcore }] } {
append errors "<li><p><b>The ns_sha1 function is missing. This function is
required in OpenACS 4.x so that passwords can be securely stored in
the database. This function is available in the nssha1 module that is part of the <a
href=\"http://www.arsdigita.com/aol3/\">ArsDigita server
distribution</a>.</b></p>"
the database.</b></p>"
set error_p 1
}
# OpenNSD must support Tcl 8.x
if { [string range [info tclversion] 0 0] < 8 } {
append errors " <li><p><strong> You are using a version of Tcl less than 8.0. You must use Tcl version 8.0
for OpenACS to work. Probably your <code>nsd</code> executable is linked to <code>nsd76</code>. Please
link it to <code>nsd8x</code> to fix this problem. Please refer to the
<a href=\"/doc/install-guide/\">Installation Guide</a>.
<blockquote><pre>
ln -s /home/aol30/bin/nsd8x /home/aol30/nsd
</pre></blockquote>
if { [info tclversion] < 8.5 } {
append errors " <li><p><strong> You are using a version of Tcl less than 8.5. You must use Tcl version 8.5
or newer for OpenACS to work. Probably your <code>nsd</code> executable is linked to an older version of Tcl.
"
set error_p 1
}
# AOLserver must support ns_cache.
if {[llength [info commands ns_cache]] < 1} {
append errors "<li><p><strong>The <code>ns_cache</code> module is not installed. This
is required to support the OpenACS Security system. Please make sure that <code>ns_cache</code>
is included in your module list. An example module list is shown below:
file (usually in <code>/home/aol30/yourservername.ini</code>) or see the
<a href=\"/doc/install-guide/\">Installation Guide</a> for more information.<p>
<blockquote><pre>
\[ns/server/bquinn/modules\]
nssock=nssock.so
nslog=nslog.so
nssha1=nssha1.so
nscache=nscache.so
</blockquote></pre>
After adding <code>ns_cache</code>, please restart your web server.
</strong></p>"
append errors "<li><p><strong>The <code>ns_cache</code> module is not installed. This is required for OpenACS."
set error_p 1
}
}
# AOLserver must have XML parsing.
if {![xml_support_ok xml_status_msg]} {
......@@ -172,7 +151,7 @@ if {![xml_support_ok xml_status_msg]} {
# AOLserver must support the "fancy" ADP parser.
set adp_support [ns_config "ns/server/[ns_info server]/adp" DefaultParser]
if {$adp_support ne "fancy" } {
if {$adp_support ne "fancy" && [ns_info name] ne "NaviServer"} {
append errors "<li><p><strong>The fancy ADP parser is not enabled. This is required to support
the OpenACS Templating System. Without this templating system, none of the OpenACS pages installed by default
will display. Please add the following to your AOLserver configuration file (usually in
......@@ -211,31 +190,31 @@ After adding support the larger stacksize, please restart your web server.
# APM needs to check its permissions.
if { [catch {apm_workspace_dir} ] } {
append errors "<li><p><strong>The [acs_root_dir] directory has incorrect permissions. It must be owned by
append errors "<li><p><strong>The $::acs::rootdir directory has incorrect permissions. It must be owned by
the user executing the web server, normally <code>nsadmin</code>, and the owner must have read and write privileges
on this directory. You can correct this by running the following script as root.
To give another user access to the files, add them to <code>web</code> group.
<blockquote><pre>
groupadd web
chown -R nsadmin:web [acs_root_dir]
chmod -R ug+rw [acs_root_dir]
chown -R nsadmin:web $::acs::rootdir
chmod -R ug+rw $::acs::rootdir
</pre></blockquote>
</strong></p>"
set error_p 1
}
# We have the workspace dir, but what about the package root?
if { ![file writable [file join [acs_root_dir] packages]] } {
append errors "<li><p><strong>The [acs_root_dir]/packages directory has incorrect permissions. It must be owned by
if { ![file writable [file join $::acs::rootdir packages]] } {
append errors "<li><p><strong>The $::acs::rootdir/packages directory has incorrect permissions. It must be owned by
the user executing the web server, normally <code>nsadmin</code> and the owner must have read and write
privileges on this directory and all of its subdirectories. You can correct this by running the following
script as root.
To give another user access to the files, add them to <code>web</code> group.
<blockquote><pre>
<blockquote><pre>
groupadd web
chown -R nsadmin:web [acs_root_dir]/packages
chmod -R ug+rw [acs_root_dir]/packages
</pre></blockquote></strong></p>"
chown -R nsadmin:web $::acs::rootdir/packages
chmod -R ug+rw $::acs::rootdir/packages
</pre></blockquote></strong></p>"
set error_p 1
}
......@@ -244,18 +223,18 @@ db_helper_checks errors error_p
# Now that we know that the database and aolserver are set up
# correctly, let's check out the actual db.
if {$error_p} {
append body "<p>
<strong>At least one misconfiguration was discovered that must be corrected.
Please fix all of them, restart the web server, and try running the OpenACS installer again.
You can proceed without resolving these errors, but the system may not function
correctly.
</strong>
<p>
<ul>
$errors
</ul>
<p>
"
append body [subst {<p>
<strong>At least one misconfiguration was discovered that must be corrected.
Please fix all of them, restart the web server, and try running the OpenACS installer again.
You can proceed without resolving these errors, but the system may not function
correctly.
</strong>
<p>
<ul>
$errors
</ul>
<p>
}]
}
# See whether the data model appears to be installed or not. The very first
......@@ -266,8 +245,9 @@ if { ![db_table_exists apm_packages] } {
# Get the default for system_url. First try to get it from the nssock
# hostname setting - if that is not available then try ns_info
if { [catch {
set system_url "http://[ns_config "ns/server/[ns_info server]/module/nssock" hostname [ns_info hostname]]"
set system_port [ns_config "ns/server/[ns_info server]/module/nssock" port [ns_conn port]]
set driversection [ns_driversection]
set system_url "http://[ns_config $driversection hostname [ns_info hostname]]"
set system_port [ns_config $driversection port [ns_conn port]]
# append port number if non-standard port
if { !($system_port == 0 || $system_port == 80) } {
......
installer/install.tcl
View file @ 8aa63e47
......@@ -8,7 +8,7 @@ install_page_contract [install_mandatory_params] [install_optional_params]
# Default all system emails to the administrators email
foreach var_name {system_owner admin_owner host_administrator outgoing_sender new_registrations} {
if { [empty_string_p [set $var_name]] } {
if { [set $var_name] eq "" } {
set $var_name $email
}
}
......@@ -61,26 +61,49 @@ if { ![db_string user_exists {
db_transaction {
set user_id [ad_user_new \
$email \
$first_names \
$last_name \
$password \
"" \
"" \
"" \
"t" \
"approved" \
"" \
$username]
# Can't use auth::create_user
# Operation GetParameters is not implemented in 'local' implementation of contract 'auth_registration'
# set user_id [auth::create_user \
# -email $email \
# -first_names $first_names \
# -last_name $last_name \
# -password $password \
# -email_verified_p "t" \
# -username $username ]
# Can't use auth::create_local_account, account does not work
# array set user [list email $email first_names $first_names \
# last_name $last_name password $password email_verified_p "t"]
# array set creation_info [auth::create_local_account \
# -authority_id [auth::authority::local] \
# -username $username \
# -array user]
# if {$creation_info(creation_status) eq "ok"} {
# set user_id $creation_info(user_id)
# }
# .. so use the low level helper
set user_id [auth::create_local_account_helper \
$email \
$first_names \
$last_name \
$password \
"" \
"" \
"" \
"t" \
"approved" \
"" \
$username ]
if { !$user_id } {
global errorInfo
install_return 200 "Unable to Create Administrator" "
Unable to create the site-wide administrator:
<blockquote><pre>[ns_quotehtml $errorInfo]</pre></blockquote>
<blockquote><pre>[ns_quotehtml $::errorInfo]</pre></blockquote>
Please <a href=\"javascript:history.back()\">try again</a>.
......@@ -101,7 +124,7 @@ Please <a href=\"javascript:history.back()\">try again</a>.
# Now process the application bundle if an install.xml file was found.
if { [file exists "[acs_root_dir]/install.xml"] } {
if { [file exists "$::acs::rootdir/install.xml"] } {
set output [apm::process_install_xml "/install.xml" {}]
ns_write "<p>[join $output "</p><p>"]</p>"
}
......
site-failure-message.tcl
View file @ 8aa63e47
......@@ -4,7 +4,7 @@
proc site_failure_handler { conn arg why } {
ns_returnfile 500 text/html "[acs_root_dir]/www/global/site-failure.html"
ns_returnfile 500 text/html "$::acs::rootdir/www/global/site-failure.html"
return "filter_return"
}
......
tcl/00-proc-procs.tcl
View file @ 8aa63e47
......@@ -29,19 +29,19 @@ proc empty_string_p { query_string } {
}
proc acs_root_dir {} {
return [nsv_get acs_properties root_directory]
return $::acs::rootdir
}
proc acs_package_root_dir { package } {
return "[file join [acs_root_dir] packages $package]"
return [file join $::acs::rootdir packages $package]
}
proc ad_make_relative_path { path } {
set root_length [string length [acs_root_dir]]
if { ![string compare [acs_root_dir] [string range $path 0 [expr { $root_length - 1 }]]] } {
return [string range $path [expr { $root_length + 1 }] [string length $path]]
set root_length [string length $::acs::rootdir]
if { $::acs::rootdir eq [string range $path 0 $root_length-1] } {
return [string range $path $root_length+1 [string length $path]]
}
error "$path is not under the path root ([acs_root_dir])"
error "$path is not under the path root ($::acs::rootdir)"
}
proc ad_get_tcl_call_stack { { level -2 }} {
......@@ -86,7 +86,7 @@ proc ad_parse_documentation_string { doc_string elements_var } {
}
proc ad_proc_valid_switch_p {str} {
return [expr [string equal "-" [string index $str 0]] && ![number_p $str]]
return [expr {[string index $str 0] eq "-" && ![number_p $str]}]
}
proc ad_proc args {
......@@ -154,6 +154,10 @@ proc ad_proc args {
return -code error "Switch -warn can be provided to ad_proc only if -deprecated is also provided"
}
if { $deprecated_p } {
set warn_p 1
}
if { $impl ne "" && $callback eq "" } {
return -code error "A callback contract name must be specified with -callback when defining an implementation with -impl"
}
......@@ -250,7 +254,7 @@ proc ad_proc args {
}
}
set arg_list [lindex $args [expr { $i + 1 }]]
set arg_list [lindex $args $i+1]
if { $n_args_remaining == 3 } {
# No doc string provided.
array set doc_elements [list]
......@@ -290,6 +294,7 @@ proc ad_proc args {
if { [llength $arg_list] > 0 } {
set first_arg [lindex $arg_list 0]
if { [llength $first_arg] == 0 || [llength $first_arg] > 2 } {
ns_log Warning "Convert old (deprecated) style proc: $proc_name"
set new_arg_list [list]
foreach { switch default_value } $first_arg {
lappend new_arg_list [list $switch $default_value]
......@@ -301,9 +306,9 @@ proc ad_proc args {
set effective_arg_list $arg_list
set last_arg [lindex $effective_arg_list end]
if { [llength $last_arg] == 1 && [string equal [lindex $last_arg 0] "args"] } {
if { [llength $last_arg] == 1 && [lindex $last_arg 0] eq "args" } {
set varargs_p 1
set effective_arg_list [lrange $effective_arg_list 0 [expr { [llength $effective_arg_list] - 2 }]]
set effective_arg_list [lrange $effective_arg_list 0 [llength $effective_arg_list]-2]
}
set check_code ""
......@@ -343,7 +348,7 @@ proc ad_proc args {
set arg [string range $arg 1 end]
lappend switches $arg
if { [lsearch $arg_flags "boolean"] >= 0 } {
if {"boolean" in $arg_flags} {
set default_values(${arg}_p) 0
append switch_code " -$arg - -$arg=1 - -$arg=t - -$arg=true {
::uplevel ::set ${arg}_p 1
......@@ -361,7 +366,7 @@ proc ad_proc args {
append switch_code " }\n"
}
if { [lsearch $arg_flags "required"] >= 0 } {
if {"required" in $arg_flags} {
append check_code " ::if { !\[::uplevel ::info exists $arg\] } {
::return -code error \"Required switch -$arg not provided\"
}
......@@ -396,11 +401,10 @@ proc ad_proc args {
set doc_elements($element) [array get $element]
}
set root_dir [nsv_get acs_properties root_directory]
set script [info script]
set root_length [string length $root_dir]
if { ![string compare $root_dir [string range $script 0 [expr { $root_length - 1 }]]] } {
set script [string range $script [expr { $root_length + 1 }] end]
set root_length [string length $::acs::rootdir]
if { $::acs::rootdir eq [string range $script 0 $root_length-1] } {
set script [string range $script $root_length+1 end]
}
set doc_elements(script) $script
......@@ -412,8 +416,9 @@ proc ad_proc args {
# Backward compatibility: set proc_doc and proc_source_file
nsv_set proc_doc $proc_name [lindex $doc_elements(main) 0]
if { [nsv_exists proc_source_file $proc_name] \
&& [nsv_get proc_source_file $proc_name] ne [info script] } {
if { [nsv_exists proc_source_file $proc_name]
&& [nsv_get proc_source_file $proc_name] ne [info script]
} {
ns_log Warning "Multiple definition of $proc_name in [nsv_get proc_source_file $proc_name] and [info script]"
}
nsv_set proc_source_file $proc_name [info script]
......@@ -429,11 +434,11 @@ proc ad_proc args {
set log_code ""
if { $warn_p } {
set log_code "ns_log Debug \"Deprecated proc $proc_name used:\\n\[ad_get_tcl_call_stack\]\"\n"
set log_code "ns_log Notice \"Deprecated proc $proc_name used:\\n\[ad_get_tcl_call_stack\]\"\n"
}
if { $callback ne "" && $impl ne "" } {
if { [llength [info procs "::callback::${callback}::contract__arg_parser"]] == 0 } {
if { [info commands "::callback::${callback}::contract__arg_parser"] eq "" } {
# We create a dummy arg parser for the contract in case
# the contract hasn't been defined yet. We need this
# because the implementation doesn't tell us what the
......@@ -508,15 +513,6 @@ $switch_code
}
}
ad_proc -public -deprecated proc_doc { args } {
A synonym for <code>ad_proc</code> (to support legacy code).
@see ad_proc
} {
eval ad_proc $args
}
ad_proc -public ad_proc {
-public:boolean
-private:boolean
......@@ -680,7 +676,7 @@ ad_proc -public ad_arg_parser { allowed_args argv } {
} {
if {[lindex $allowed_args end] eq "args"} {
set varargs_p 1
set allowed_args [lrange $allowed_args 0 [expr { [llength $allowed_args] - 2 }]]
set allowed_args [lrange $allowed_args 0 [llength $allowed_args]-2]
} else {
set varargs_p 0
}
......@@ -770,7 +766,7 @@ ad_proc -public callback {
list of returns still returned. If not given an error simply is passed
further on.
@params args pass the set of arguments on to each callback
@param args pass the set of arguments on to each callback
@return list of the returns from each callback that does a normal (non-empty) return
......@@ -783,16 +779,15 @@ ad_proc -public callback {
# arg validation -- ::callback::${callback}::contract is an
# empty function that only runs the ad_proc generated arg parser.
if {[llength [info proc ::callback::${callback}::contract]] != 1} {
if {[info commands ::callback::${callback}::contract] eq ""} {
error "Undefined callback $callback"
}
eval ::callback::${callback}::contract $args
::callback::${callback}::contract {*}$args
set returns {}
set base ::callback::${callback}::impl
foreach procname [lsort [info procs ${base}::$impl]] {
foreach procname [lsort [info commands ${base}::$impl]] {
set c [catch {::uplevel 1 $procname $args} ret]
switch -exact $c {
0 { # code ok
......@@ -824,7 +819,7 @@ ad_proc -public callback {
}
}
if {![string equal $impl *] && ![info exists c] && !$catch_p} {
if {$impl ne "*" && ![info exists c] && !$catch_p} {
error "callback $callback implementation $impl does not exist"
}
......@@ -907,7 +902,7 @@ ad_proc -public ad_call_method {
@param object_id the target, it is the first arg to the method
@param args the remaining arguments
} {
return [ad_apply ${method_name}__[util_memoize "acs_object_type $object_id"] [concat $object_id $args]]
return [ad_apply ${method_name}__[util_memoize [list acs_object_type $object_id]] [concat $object_id $args]]
}
ad_proc -public ad_dispatch {
......@@ -935,8 +930,8 @@ ad_proc -public ad_assert_arg_value_in_list {
For use at the beginning of the body of a procedure to
check that an argument has one of a number of allowed values.
@arg_name The name of the argument to check
@allowed_values_list The list of values that are permissible for the argument
@param arg_name The name of the argument to check
@param allowed_values_list The list of values that are permissible for the argument
@return Returns 1 if the argument has a valid value, throws an informative
error otherwise.
......@@ -945,7 +940,7 @@ ad_proc -public ad_assert_arg_value_in_list {
} {
upvar $arg_name arg_value
if { [lsearch -exact $allowed_values_list $arg_value] == -1 } {
if {$arg_value ni $allowed_values_list} {
error "argument $arg_name has value $arg_value but must be in ([join $allowed_values_list ", "])"
}
......
tcl/10-utilities-procs.tcl
View file @ 8aa63e47
......@@ -8,11 +8,9 @@ ad_library {
}
ad_proc -public ad_find_all_files {
{
-include_dirs 0
-max_depth 10
-check_file_func ""
}
{-include_dirs 0}
{-max_depth 10}
{-check_file_func ""}
path
} {
......@@ -45,7 +43,7 @@ ad_proc -public ad_find_all_files {
# Remember that we've examined the file.
set examined_files($file) 1
if { $check_file_func eq "" || [eval [list $check_file_func $file]] } {
if { $check_file_func eq "" || [$check_file_func $file] } {
# If it's a file, add to our list. If it's a
# directory, add its contents to our list of files to
# examine next time.
......@@ -55,7 +53,7 @@ ad_proc -public ad_find_all_files {
if { $include_dirs == 1 } {
lappend files $file
}
set new_files_to_examine [concat $new_files_to_examine [glob -nocomplain "$file/*"]]
lappend new_files_to_examine {*}[glob -nocomplain "$file/*"]
}
}
}
......
tcl/20-db-bootstrap-procs.tcl
View file @ 8aa63e47
ad_proc -private db_available_pools {{} dbn } {
ad_proc -private db_available_pools {dbn} {
Returns a list of the available pools for the given database name.
<p>
......@@ -20,8 +20,7 @@ ad_proc -private db_available_pools {{} dbn } {
return [nsv_get {db_available_pools} $dbn]
}
ad_proc -private db_pool_to_dbn_init {{
}} {
ad_proc -private db_pool_to_dbn_init {} {
Simply initializes the <code>db_pool_to_dbn</code> nsv, which is
used by "<code>db_driverkey -handle</code>".
......@@ -138,7 +137,7 @@ ad_proc db_bootstrap_set_db_type { errors } {
ns_log Notice "$proc_name: For database '$dbn', the following pools are available: $dbn_pools"
}
if { [empty_string_p [db_available_pools $default_dbn]] } {
if { [db_available_pools $default_dbn] eq "" } {
ns_log Error "$proc_name: No pools specified for database '$default_dbn'."
set old_availablepool_p 1
}
......
tcl/30-apm-load-procs.tcl
View file @ 8aa63e47
This diff is collapsed.
tcl/40-db-query-dispatcher-procs.tcl
View file @ 8aa63e47
......@@ -16,7 +16,7 @@
# The following code allows ad_proc to be used
# here (a local workalike is declared if absent).
# added 2002-09-11 Jeff Davis (davis@xarg.net)
if {{} ne [info procs ad_library] } {
if {[info commands ad_library] ne "" } {
ad_library {
Query Dispatching for multi-RDBMS capability
......@@ -26,7 +26,7 @@ if {{} ne [info procs ad_library] } {
}
}
if { {} ne [info procs ad_proc] } {
if { [info commands ad_proc] ne ""} {
set remove_ad_proc_p 0
} else {
set remove_ad_proc_p 1
......@@ -86,7 +86,7 @@ ad_proc -public db_rdbms_compatible_p {rdbms_test rdbms_pattern} {
# db_qd_log QDDebug "The RDBMS_PATTERN is [db_rdbms_get_type $rdbms_pattern] - [db_rdbms_get_version $rdbms_pattern]"
# If the pattern is for all RDBMS, then yeah, compatible
if {[empty_string_p [db_rdbms_get_type $rdbms_test]]} {
if {[db_rdbms_get_type $rdbms_test] eq ""} {
return 1
}
......@@ -97,16 +97,16 @@ ad_proc -public db_rdbms_compatible_p {rdbms_test rdbms_pattern} {
}
# If the pattern has no version
if {[empty_string_p [db_rdbms_get_version $rdbms_pattern]]} {
if {[db_rdbms_get_version $rdbms_pattern] eq ""} {
return 1
}
# If the query being tested was written for a version that is older than
# the current RDBMS then we have compatibility. Otherwise we don't.
foreach t [split [db_rdbms_get_version $rdbms_test ] "\."] \
p [split [db_rdbms_get_version $rdbms_pattern] "\."] {
if {$t != $p} {return [expr {$t < $p}]}
}
p [split [db_rdbms_get_version $rdbms_pattern] "\."] {
if {$t != $p} {return [expr {$t < $p}]}
}
# Same version (though not strictly "older") is OK
return 1
......@@ -194,11 +194,11 @@ ad_proc -public db_qd_pick_most_specific_query {rdbms query_1 query_2} {
# We ASSUME that both queries are at least compatible.
# Otherwise this is a stupid exercise
if {[empty_string_p [db_rdbms_get_version $rdbms_1]]} {
if {[db_rdbms_get_version $rdbms_1] eq ""} {
return $query_2
}
if {[empty_string_p [db_rdbms_get_version $rdbms_2]]} {
if {[db_rdbms_get_version $rdbms_2] eq ""} {
return $query_1
}
......@@ -217,13 +217,22 @@ ad_proc -public db_qd_pick_most_specific_query {rdbms query_1 query_2} {
#
################################################
ad_proc -public db_qd_load_query_file {file_path} {
ad_proc -public db_qd_load_query_file {file_path {errorVarName ""}} {
A procedure that is called from the outside world (APM)
to load a particular file
} {
if { [catch {db_qd_internal_load_cache $file_path} errmsg] } {
global errorInfo
ns_log Error "Error parsing queryfile $file_path:\n\n$errmsg\n\n$errorInfo"
} {
if {$errorVarName ne ""} {
upvar $errorVarName errors
} else {
array set errors [list]
}
if { [catch {db_qd_internal_load_cache $file_path} errMsg] } {
set backTrace $::errorInfo
ns_log Error "Error parsing queryfile $file_path:\n\n$errMsg\n\n$backTrace"
set r_file [ad_make_relative_path $file_path]
set package_key ""
regexp {/packages/([^/]+)/} $file_path -> package_key
lappend errors($package_key) $r_file $backTrace
}
}
......@@ -256,7 +265,7 @@ ad_proc -public db_qd_get_fullname {local_name {added_stack_num 1}} {
# We check if we're running the special ns_ proc that tells us
# whether this is an URL or a Tcl proc.
if {[lsearch $list_of_source_procs [lindex $proc_name 0]] != -1} {
if { [lindex $proc_name 0] in $list_of_source_procs } {
# Means we are running inside an URL
......@@ -345,8 +354,7 @@ ad_proc -public db_qd_get_fullname {local_name {added_stack_num 1}} {
# db_qd_log QDDebug "calling namespace = $calling_namespace"
if {$calling_namespace ne "" &&
![regexp {::} $proc_name all]} {
![string match "*::*" $proc_name]} {
set proc_name ${calling_namespace}::${proc_name}
}
# db_qd_log QDDebug "proc_name is -$proc_name-"
......@@ -387,20 +395,18 @@ ad_proc -public db_qd_get_fullname {local_name {added_stack_num 1}} {
# db_qd_log QDDebug "generated fullname of $full_name"
# The following block is apparently just for debugging
# aks - making debug output actually useable
if {[llength $proc_name] > 1} {
set proc_name_with_parameters "[lindex $proc_name 0] "
set i 1
foreach parameter [lrange $proc_name 1 end] {
append proc_name_with_parameters "parameter$i: $parameter "
incr i
}
} else {
set proc_name_with_parameters $proc_name
}
# if {[llength $proc_name] > 1} {
# set proc_name_with_parameters "[lindex $proc_name 0] "
# set i 1
# foreach parameter [lrange $proc_name 1 end] {
# append proc_name_with_parameters "parameter$i: $parameter "
# incr i
# }
# } else {
# set proc_name_with_parameters $proc_name
# }
# db_qd_log QDDebug "db_qd_get_fullname: following query in file: $url proc: $proc_name_with_parameters"
return $full_name
......@@ -420,12 +426,7 @@ ad_proc -public db_qd_fetch {fullquery_name {rdbms {}}} {
ad_proc -public db_qd_replace_sql {statement_name sql} {
@return sql for statement_name (defaulting to sql if not found)
} {
# Fraber 20120907: Write out a line with the DB statment for every
# query made. This way we can determine the test coverage for
# semiautomatic testing
db_qd_log Debug "db_qd_replace_sql: $statement_name"
} {
set fullquery [db_qd_fetch $statement_name]
if {$fullquery ne ""} {
......@@ -531,12 +532,12 @@ ad_proc -private db_qd_internal_load_queries {file_pointer file_tag} {
set new_name [db_qd_make_absolute_path $queryname_root [db_fullquery_get_name $one_query]]
set new_fullquery [db_fullquery_create \
$new_name \
[db_fullquery_get_querytext $one_query] \
[db_fullquery_get_bind_vars $one_query] \
[db_fullquery_get_query_type $one_query] \
[db_fullquery_get_rdbms $one_query] \
[db_fullquery_get_load_location $one_query]]
$new_name \
[db_fullquery_get_querytext $one_query] \
[db_fullquery_get_bind_vars $one_query] \
[db_fullquery_get_query_type $one_query] \
[db_fullquery_get_rdbms $one_query] \
[db_fullquery_get_load_location $one_query]]
set one_query $new_fullquery
......@@ -548,7 +549,7 @@ ad_proc -private db_qd_internal_load_queries {file_pointer file_tag} {
}
set relative_path [string range $file_tag \
[expr { [string length [acs_root_dir]] + 1 }] end]
[expr { [string length $::acs::rootdir] + 1 }] end]
nsv_set apm_library_mtime $relative_path [file mtime $file_tag]
}
......@@ -810,7 +811,7 @@ ad_proc -private db_qd_relative_path_p {path} {
set root_path_length [string length $root_path]
# Check if the path starts with the root
if {[string range $path 0 [expr {$root_path_length - 1}]] == $root_path} {
if {[string range $path 0 $root_path_length-1] eq $root_path} {
return 0
} else {
return 1
......@@ -861,13 +862,13 @@ ad_proc -private db_qd_internal_prepare_queryfile_content {file_content} {
append new_file_content [string range $rest_of_file_content 0 [expr {$first_querytext_open + $querytext_open_len - 1}]]
# append quoted querytext
append new_file_content [ns_quotehtml [string range $rest_of_file_content [expr {$first_querytext_open + $querytext_open_len}] [expr {$first_querytext_close - 1}]]]
append new_file_content [ns_quotehtml [string range $rest_of_file_content $first_querytext_open+$querytext_open_len $first_querytext_close-1]]
# append close querytext
append new_file_content $querytext_close
# Set up the rest
set rest_of_file_content [string range $rest_of_file_content [expr {$first_querytext_close + $querytext_close_len}] end]
set rest_of_file_content [string range $rest_of_file_content $first_querytext_close+$querytext_close_len end]
}
# db_qd_log QDDebug "new massaged file content: \n $new_file_content \n"
......@@ -893,3 +894,10 @@ ad_proc -private db_qd_log {level msg} {
if { $remove_ad_proc_p } {
rename ad_proc {}
}
#
# Local variables:
# mode: tcl
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
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