Index: openacs-4/packages/acs-ldap-authentication/tcl/ldap-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-ldap-authentication/tcl/ldap-procs.tcl,v
diff -u -r1.3 -r1.4
--- openacs-4/packages/acs-ldap-authentication/tcl/ldap-procs.tcl 31 Jan 2018 20:54:06 -0000 1.3
+++ openacs-4/packages/acs-ldap-authentication/tcl/ldap-procs.tcl 23 Apr 2018 15:19:31 -0000 1.4
@@ -11,7 +11,7 @@
# The following two are temporary
ad_proc default_parameter_value {
- parameter_name package_key
+ parameter_name package_key
} {
return [db_string parameter_value {
select default_value
@@ -33,18 +33,18 @@
}
ad_proc -public ldap_user_exists { email } {
- Checks to see if a user with the given email address exists in either the local
+ Checks to see if a user with the given email address exists in either the local
database or on the LDAP server. Returns 1 if the user exists, 0 otherwise.
} {
# check to see if the user is in the local cc_users table
set user_id [cc_email_user $email]
- if ![empty_string_p $user_id] {
+ if { $user_id ne "" } {
# user is in local database
return 1
}
# check the LDAP server
set dn [ldap_get_dn_from_email $email]
- if ![empty_string_p $dn] {
+ if { $dn ne "" } {
# user is on LDAP server
return 1
}
@@ -64,15 +64,15 @@
set dn [db_exec_plsql get_dn_from_email {
begin
:1 := acs_ldap.get_dn_from_email(
- url => :url,
- rootdn => :rootdn,
- rootpw => :rootpw,
- basedn => :basedn,
- security_method => :security_method,
+ url => :url,
+ rootdn => :rootdn,
+ rootpw => :rootpw,
+ basedn => :basedn,
+ security_method => :security_method,
email => :email);
end;
}]
-
+
if ![ldap_valid_value_p $dn] {
# There was a problem with the query
ns_log Notice "ldap_get_dn_from_email: invalid value $dn"
@@ -81,15 +81,15 @@
# Relative DNs are returned from the LDAP call. If a basedn is
# supplied, append it now to set the full DN.
- if ![empty_string_p $basedn] {
+ if { $basedn ne "" } {
set dn "$dn, $basedn"
- }
+ }
return $dn
}
-ad_proc -public ldap_check_password { email password_from_form } {
- Returns the user's user_id if the password is correct for the given email.
+ad_proc -public ldap_check_password { email password_from_form } {
+ Returns the user's user_id if the password is correct for the given email.
Returns the empty_string otherwise. If the password is correct, it also updates
the user's local information from the LDAP server.
} {
@@ -99,7 +99,7 @@
# Get the dn for the password
set dn [ldap_get_dn_from_email $email]
- if [empty_string_p $dn] {
+ if { $dn eq "" } {
# No user with the email address given is on the LDAP server
return ""
}
@@ -112,9 +112,9 @@
if ![db_exec_plsql password_validate {
begin
:1 := acs_ldap.authenticate (
- url => :url,
- security_method => :security_method,
- dn => :dn,
+ url => :url,
+ security_method => :security_method,
+ dn => :dn,
password => :password);
end;
}] {
@@ -123,7 +123,7 @@
# check to see if the user is in the local cc_users table
set user_id [cc_email_user $email]
- if [empty_string_p $user_id] {
+ if { $user_id eq "" } {
# insert user into local database
set user_id [ldap_add_user_from_dn $dn]
@@ -141,7 +141,7 @@
return $user_id
}
-ad_proc -public ldap_change_password { dn password_from_form } {
+ad_proc -public ldap_change_password { dn password_from_form } {
Change the user's password on the LDAP server. Return 1 if successful,
0 otherwise.
} {
@@ -157,15 +157,15 @@
if ![db_exec_plsql password_update {
begin
:1 := acs_ldap.change_password (
- url => :url,
- rootdn => :rootdn,
- rootpw => :rootpw,
- security_method => :security_method,
- dn => :dn,
+ url => :url,
+ rootdn => :rootdn,
+ rootpw => :rootpw,
+ security_method => :security_method,
+ dn => :dn,
password => :password);
end;
} ] {
- return 0
+ return 0
}
set user_id [db_string user_id_select {
@@ -174,21 +174,21 @@
where dn = :dn
} -default ""]
- if ![empty_string_p $user_id] {
+ if { $user_id ne "" } {
# Keep local password in sync
ad_change_password $user_id $password_from_form
}
return 1
}
-ad_proc -public ldap_user_new {
+ad_proc -public ldap_user_new {
{ -dn "" }
- email first_names last_name password password_question password_answer
- {url ""} {email_verified_p "t"} {member_state "approved"} {user_id ""}
+ email first_names last_name password password_question password_answer
+ {url ""} {email_verified_p "t"} {member_state "approved"} {user_id ""}
} {
Creates a new user locally. Then associates this user with the
- given dn if one is supplied or with a newly created dn otherwise.
+ given dn if one is supplied or with a newly created dn otherwise.
Returns the user_id upon success or the empty_string upon failure.
} {
ns_log debug "LDAP_USER_NEW $dn $email $first_names $last_name"
@@ -197,26 +197,26 @@
$password $password_question $password_answer $url \
$email_verified_p $member_state $user_id]
- if !$user_id {
+ if !$user_id {
# We could not create the user locally so exit.
- return ""
+ return ""
}
- if [empty_string_p $dn] {
+ if { $dn eq "" } {
# No dn was supplied so we need to create one
set dn [ldap_make_dn $user_id]
}
- if ![ldap_add_object $user_id $dn] {
- # We could not associate the dn with the user
- return 0
+ if ![ldap_add_object $user_id $dn] {
+ # We could not associate the dn with the user
+ return 0
}
return $user_id
}
ad_proc ldap_add_user_to_server { dn first_names last_name email password } {
- Add an entry to the LDAP server for the given dn and populate it with
+ Add an entry to the LDAP server for the given dn and populate it with
the infor from the other arguments. Return 1 upon success or 0 otherwise.
} {
ns_log debug "LDAP_ADD_USER_TO_SERVER $dn $first_names $last_name $email $password"
@@ -227,14 +227,14 @@
set dn [db_exec_plsql user_add {
begin
:1 := acs_ldap.add_user (
- url => :url,
- rootdn => :rootdn,
- rootpw => :rootpw,
- security_method => :security_method,
- dn => :dn,
- first_names => :first_names,
- last_name => :last_name,
- email => :email,
+ url => :url,
+ rootdn => :rootdn,
+ rootpw => :rootpw,
+ security_method => :security_method,
+ dn => :dn,
+ first_names => :first_names,
+ last_name => :last_name,
+ email => :email,
password => :password);
end;
} ]
@@ -267,15 +267,15 @@
db_dml party_info_update {
update parties
set email = :email
- where party_id = (select object_id
+ where party_id = (select object_id
from ldap_attributes
where dn = :dn)
}
db_dml person_info_update {
update persons
set first_names = :first_names,
last_name = :last_name
- where person_id = (select object_id
+ where person_id = (select object_id
from ldap_attributes
where dn = :dn)
}
@@ -314,7 +314,7 @@
}
ad_proc -public ldap_get_attribute { dn attribute } {
- Queries the LDAP server for the value of the given attribute in the entry designated
+ Queries the LDAP server for the value of the given attribute in the entry designated
by the DN.
} {
# Set the LDAP environment variables
@@ -323,16 +323,16 @@
return [db_exec_plsql attribute_fetch {
begin
:1 := acs_ldap.get_attribute (
- url => :url,
- rootdn => :rootdn,
- rootpw => :rootpw,
- security_method => :security_method,
- dn => :dn,
+ url => :url,
+ rootdn => :rootdn,
+ rootpw => :rootpw,
+ security_method => :security_method,
+ dn => :dn,
attribute => :attribute);
end;
}]
}
-
+
ad_proc -private ldap_set_environment {} {
A convenience function for setting up common local variables from LDAP Package parameter
values.
@@ -360,7 +360,7 @@
ns_log warning "ldap_set_environment: Failed on insert into ldap_attributes for object $object_id with dn $dn: $errmsg"
return 0
}
-
+
return 1
}
Index: openacs-4/packages/acs-ldap-authentication/www/examples/user-login.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-ldap-authentication/www/examples/user-login.tcl,v
diff -u -r1.2 -r1.3
--- openacs-4/packages/acs-ldap-authentication/www/examples/user-login.tcl 18 Sep 2002 12:08:20 -0000 1.2
+++ openacs-4/packages/acs-ldap-authentication/www/examples/user-login.tcl 23 Apr 2018 15:19:31 -0000 1.3
@@ -19,7 +19,7 @@
}
set user_id [ldap_check_password $email $password]
-if [empty_string_p $user_id] {
+if { $user_id eq "" } {
# The user is in the database, but has provided an incorrect password.
ad_returnredirect "bad-password?user_id=$user_id"
ad_script_abort
Index: openacs-4/packages/acs-ldap-authentication/www/examples/user-new-2.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-ldap-authentication/www/examples/user-new-2.tcl,v
diff -u -r1.4 -r1.5
--- openacs-4/packages/acs-ldap-authentication/www/examples/user-new-2.tcl 19 Jan 2018 21:23:51 -0000 1.4
+++ openacs-4/packages/acs-ldap-authentication/www/examples/user-new-2.tcl 23 Apr 2018 15:19:31 -0000 1.5
@@ -49,7 +49,7 @@
if {[parameter::get -parameter RegistrationProvidesRandomPasswordP -default 0]} {
set password [ad_generate_random_string]
-} elseif { ![info exists password] || [empty_string_p $password] } {
+} elseif { ![info exists password] || $password eq "" } {
incr exception_count
append exception_text "<li>You haven't provided a password.\n"
} elseif { [string compare $password $password_confirmation] } {
@@ -75,14 +75,14 @@
} else {
set dn [ldap_make_dn $user_id]
set result [ldap_add_user_to_server $dn $first_names $last_name $email $password]
- if [empty_string_p $result] {
+ if { $result eq "" } {
ad_return_error "User Creation Failed" "We were unable to create your user record in the ldap database."
ad_script_abort
}
set user_id [ldap_user_new -dn $dn $email $first_names $last_name $password $question \
$answer $url $email_verified_p $member_state $user_id]
if { !$user_id } {
- ad_return_error "User Creation Failed" "We were unable to create your user record in the database."
+ ad_return_error "User Creation Failed" "We were unable to create your user record in the database."
ad_script_abort
}
}
Index: openacs-4/packages/acs-mail/tcl/acs-mail-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-mail/tcl/acs-mail-procs.tcl,v
diff -u -r1.10 -r1.11
--- openacs-4/packages/acs-mail/tcl/acs-mail-procs.tcl 4 Jun 2006 00:45:40 -0000 1.10
+++ openacs-4/packages/acs-mail/tcl/acs-mail-procs.tcl 23 Apr 2018 15:19:31 -0000 1.11
@@ -11,64 +11,64 @@
# base64 encode a string
proc acs_mail_base64_encode {string} {
- if [nsv_get acs_mail ns_uuencode_works_p] {
- # ns_uuencode works - use it
+ if [nsv_get acs_mail ns_uuencode_works_p] {
+ # ns_uuencode works - use it
- # split it into chunks of 48 chars and then encode it
- set length [string length $string]
- for { set i 0 } { [expr $i + 48 ] < $length } { incr i 48 } {
- append result "[ns_uuencode [string range $string $i [expr $i+47]]]\n"
- }
- append result [ns_uuencode [string range $string $i end]]
- } else {
- # ns_uuencode doesn't work - use the tcl version
+ # split it into chunks of 48 chars and then encode it
+ set length [string length $string]
+ for { set i 0 } { [expr $i + 48 ] < $length } { incr i 48 } {
+ append result "[ns_uuencode [string range $string $i [expr $i+47]]]\n"
+ }
+ append result [ns_uuencode [string range $string $i end]]
+ } else {
+ # ns_uuencode doesn't work - use the tcl version
- set i 0
- foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
- a b c d e f g h i j k l m n o p q r s t u v w x y z \
- 0 1 2 3 4 5 6 7 8 9 + /} {
- set base64_en($i) $char
- incr i
- }
-
- set result {}
- set state 0
- set length 0
- foreach {c} [split $string {}] {
- if { $length >= 60 } {
- append result "\n"
- set length 0
- }
- scan $c %c x
- switch [incr state] {
- 1 { append result $base64_en([expr {($x >>2) & 0x3F}]) }
- 2 { append result \
- $base64_en([expr {(($old << 4) & 0x30) | (($x >> 4) & 0xF)}]) }
- 3 { append result \
- $base64_en([expr {(($old << 2) & 0x3C) | (($x >> 6) & 0x3)}])
- append result $base64_en([expr {($x & 0x3F)}])
- incr length
- set state 0}
- }
- set old $x
- incr length
- }
- set x 0
- switch $state {
- 0 { # OK }
- 1 { append result $base64_en([expr {(($old << 4) & 0x30)}])== }
- 2 { append result $base64_en([expr {(($old << 2) & 0x3C)}])= }
- }
- }
+ set i 0
+ foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
+ a b c d e f g h i j k l m n o p q r s t u v w x y z \
+ 0 1 2 3 4 5 6 7 8 9 + /} {
+ set base64_en($i) $char
+ incr i
+ }
+ set result {}
+ set state 0
+ set length 0
+ foreach {c} [split $string {}] {
+ if { $length >= 60 } {
+ append result "\n"
+ set length 0
+ }
+ scan $c %c x
+ switch [incr state] {
+ 1 { append result $base64_en([expr {($x >>2) & 0x3F}]) }
+ 2 { append result \
+ $base64_en([expr {(($old << 4) & 0x30) | (($x >> 4) & 0xF)}]) }
+ 3 { append result \
+ $base64_en([expr {(($old << 2) & 0x3C) | (($x >> 6) & 0x3)}])
+ append result $base64_en([expr {($x & 0x3F)}])
+ incr length
+ set state 0}
+ }
+ set old $x
+ incr length
+ }
+ set x 0
+ switch $state {
+ 0 { # OK }
+ 1 { append result $base64_en([expr {(($old << 4) & 0x30)}])== }
+ 2 { append result $base64_en([expr {(($old << 2) & 0x3C)}])= }
+ }
+ }
+
return $result
}
ad_proc -private acs_mail_set_content {
- {-body_id:required}
- {-header_subject ""}
- {-creation_user ""}
- {-creation_ip ""}
+ {-body_id:required}
+ {-header_subject ""}
+ {-creation_user ""}
+ {-creation_ip ""}
{-content:required}
{-content_type:required}
{-nls_language}
@@ -84,44 +84,44 @@
}
set item_id [db_exec_plsql insert_new_content "
- begin
- return content_item__new(
- varchar 'acs-mail message $body_id', -- new__name
- null, -- new__parent_id
- null, -- new__item_id
- null, -- new__locale
- now(), -- new__creation_date
- :creation_user, -- new__creation_user
- null, -- new__context_id
- :creation_ip, -- new__creation_ip
- 'content_item', -- new__item_subtype
- 'content_revision', -- new__content_type
- :header_subject, -- new__title
- null, -- new__description
- :content_type, -- new__mime_type
- :nls_language, -- new__nls_language
- :content, -- new__text
- 'text' -- new__storage_type
- );
- end;"
- ]
-
- set revision_id [db_exec_plsql get_latest_revision "
- begin
- return content_item__get_latest_revision ( :item_id );
- end;"
- ]
+ begin
+ return content_item__new(
+ varchar 'acs-mail message $body_id', -- new__name
+ null, -- new__parent_id
+ null, -- new__item_id
+ null, -- new__locale
+ now(), -- new__creation_date
+ :creation_user, -- new__creation_user
+ null, -- new__context_id
+ :creation_ip, -- new__creation_ip
+ 'content_item', -- new__item_subtype
+ 'content_revision', -- new__content_type
+ :header_subject, -- new__title
+ null, -- new__description
+ :content_type, -- new__mime_type
+ :nls_language, -- new__nls_language
+ :content, -- new__text
+ 'text' -- new__storage_type
+ );
+ end;"
+ ]
- db_exec_plsql set_live_revision "select content_item__set_live_revision(:revision_id)"
+ set revision_id [db_exec_plsql get_latest_revision "
+ begin
+ return content_item__get_latest_revision ( :item_id );
+ end;"
+ ]
+ db_exec_plsql set_live_revision "select content_item__set_live_revision(:revision_id)"
+
return $item_id
}
ad_proc -private acs_mail_set_content_file {
- {-body_id:required}
- {-header_subject ""}
- {-creation_user ""}
- {-creation_ip ""}
+ {-body_id:required}
+ {-header_subject ""}
+ {-creation_user ""}
+ {-creation_ip ""}
{-content_file:required}
{-content_type:required}
{-nls_language}
@@ -137,58 +137,58 @@
}
set item_id [db_exec_plsql insert_new_content "
- begin
- return content_item__new(
- varchar 'acs-mail message $body_id', -- new__name
- null, -- new__parent_id
- null, -- new__item_id
- null, -- new__locale
- now(), -- new__creation_date
- :creation_user, -- new__creation_user
- null, -- new__context_id
- :creation_ip, -- new__creation_ip
- 'content_item', -- new__item_subtype
- 'content_revision', -- new__content_type
- :header_subject, -- new__title
- null, -- new__description
- :content_type, -- new__mime_type
- :nls_language, -- new__nls_language
- null, -- new__text
- 'file' -- new__storage_type
- );
- end;"
- ]
-
- set revision_id [db_exec_plsql get_latest_revision "
- begin
- return content_item__get_latest_revision ( :item_id );
- end;"
- ]
+ begin
+ return content_item__new(
+ varchar 'acs-mail message $body_id', -- new__name
+ null, -- new__parent_id
+ null, -- new__item_id
+ null, -- new__locale
+ now(), -- new__creation_date
+ :creation_user, -- new__creation_user
+ null, -- new__context_id
+ :creation_ip, -- new__creation_ip
+ 'content_item', -- new__item_subtype
+ 'content_revision', -- new__content_type
+ :header_subject, -- new__title
+ null, -- new__description
+ :content_type, -- new__mime_type
+ :nls_language, -- new__nls_language
+ null, -- new__text
+ 'file' -- new__storage_type
+ );
+ end;"
+ ]
- db_exec_plsql set_live_revision "select content_item__set_live_revision(:revision_id)"
+ set revision_id [db_exec_plsql get_latest_revision "
+ begin
+ return content_item__get_latest_revision ( :item_id );
+ end;"
+ ]
- db_dml update_content {
+ db_exec_plsql set_live_revision "select content_item__set_live_revision(:revision_id)"
+
+ db_dml update_content {
update cr_revisions
set content = empty_blob()
where revision_id = :revision_id
returning content into :1
} -blob_files [list $content_file]
-
- return $item_id
-
+
+ return $item_id
+
}
ad_proc -private acs_mail_uuencode_file {
- file_path
+ file_path
} {
- Base64 encode binary content from a file
+ Base64 encode binary content from a file
} {
- set fd [open "$file_path" r]
- fconfigure $fd -encoding binary
- set file_input [read $fd]
- close $fd
+ set fd [open "$file_path" r]
+ fconfigure $fd -encoding binary
+ set file_input [read $fd]
+ close $fd
- return [acs_mail_base64_encode $file_input]
+ return [acs_mail_base64_encode $file_input]
}
@@ -198,147 +198,147 @@
ns_log Debug "acs-mail: encode: starting $content_item_id"
# What sort of content do we have?
if ![acs_mail_multipart_p $content_item_id] {
- ns_log Debug "acs-mail: encode: one part $content_item_id"
+ ns_log Debug "acs-mail: encode: one part $content_item_id"
# Easy as pie.
# Let's get the data.
- # vinodk: first get the latest revision
- set revision_id [db_exec_plsql get_latest_revision "
- begin
- return content_item__get_latest_revision ( :content_item_id );
- end;"
- ]
+ # vinodk: first get the latest revision
+ set revision_id [db_exec_plsql get_latest_revision "
+ begin
+ return content_item__get_latest_revision ( :content_item_id );
+ end;"
+ ]
- set storage_type [db_string get_storage_type "
- select storage_type from cr_items
- where item_id = :content_item_id
- "]
-
- if [db_0or1row acs_mail_body_to_mime_get_content_simple {
- select content, mime_type as v_content_type
- from cr_revisions
- where revision_id = :revision_id
- }] {
- if [string equal $storage_type text] {
- ns_log Debug "acs-mail: encode: one part hit $content_item_id"
- # vinodk: no need for this, since we're checking
- # storage_type
- #
- # We win! Hopefully. Check if there are 8bit characters/data.
- # HT NL CR SP-~ The full range of ASCII with spaces but no
- # control characters.
- #if ![regexp "\[^\u0009\u000A\u000D\u0020-\u007E\]" $content] {
- # ns_log Debug "acs-mail: encode: good code $content_item_id"
- # # We're still okay. Use it!
- return [list $v_content_type $content]
- #}
- #ns_log "Notice" "acs-mail: encode: bad code $content_item_id"
- } else {
- # this content is in the file system or a blob
- ns_log Debug "acs-mail: encode: binary content $content_item_id"
+ set storage_type [db_string get_storage_type "
+ select storage_type from cr_items
+ where item_id = :content_item_id
+ "]
- if [string equal $storage_type file] {
- ns_log Debug "acs-mail: encode: file $content_item_id"
- set encoded_content [acs_mail_uuencode_file [cr_fs_path]$content]
- } else {
- ns_log Debug "acs-mail: encode: lob $content_item_id"
- # Blob. Now we need to decide if this is binary
- # so we can uuencode it if necessary.
- # We'll use the mime type to decide
-
- if { [string first "text" $v_content_type] == 0 } {
- ns_log Debug "acs-mail: encode: plain content"
- set encoded_content "$content"
- } else {
- # binary content - copy the blob to temp file
- # that we will then uuencode
- set file [ns_tmpnam]
- db_blob_get_file copy_blob_to_file "
- select r.content, i.storage_type
- from cr_revisions r, cr_items i
- where r.revision_id = $revision_id and
- r.item_id = i.item_id " -file $file
- ns_log Debug "acs-mail: encode: binary content"
- set encoded_content [acs_mail_uuencode_file $file]
- }
- }
+ if [db_0or1row acs_mail_body_to_mime_get_content_simple {
+ select content, mime_type as v_content_type
+ from cr_revisions
+ where revision_id = :revision_id
+ }] {
+ if { $storage_type eq "text" } {
+ ns_log Debug "acs-mail: encode: one part hit $content_item_id"
+ # vinodk: no need for this, since we're checking
+ # storage_type
+ #
+ # We win! Hopefully. Check if there are 8bit characters/data.
+ # HT NL CR SP-~ The full range of ASCII with spaces but no
+ # control characters.
+ #if ![regexp "\[^\u0009\u000A\u000D\u0020-\u007E\]" $content] {
+ # ns_log Debug "acs-mail: encode: good code $content_item_id"
+ # # We're still okay. Use it!
+ return [list $v_content_type $content]
+ #}
+ #ns_log "Notice" "acs-mail: encode: bad code $content_item_id"
+ } else {
+ # this content is in the file system or a blob
+ ns_log Debug "acs-mail: encode: binary content $content_item_id"
- return [list $v_content_type $encoded_content]
- }
- }
- } else {
- # Harder. Oops.
- ns_log Debug "acs-mail: encode: multipart $content_item_id"
- set boundary "=-=-="
- set contents {}
- # Get the component pieces
- set multipart_list [db_list_of_lists acs_mail_body_to_mime_get_contents {
- select mime_filename, mime_disposition, content_item_id as ci_id
- from acs_mail_multipart_parts
- where multipart_id = :content_item_id
- order by sequence_number
- }
- ]
-
- if ![empty_string_p $multipart_list] {
- foreach multipart_item $multipart_list {
- set mime_filename [lindex $multipart_item 0]
- set mime_disposition [lindex $multipart_item 1]
- set ci_id [lindex $multipart_item 2]
-
- if {[string equal "" $mime_disposition]} {
- if {![string equal "" $mime_filename]} {
- set mime_disposition "attachment; filename=$mime_filename"
- } else {
- set mime_disposition "inline"
- }
- } else {
- if {![string equal "" $mime_filename]} {
- set mime_disposition \
- "$mime_disposition; filename=$mime_filename"
- }
- }
- set content [acs_mail_encode_content $ci_id]
- while {[regexp -- "--$boundary--" $content]} {
- set boundary "=$boundary"
- }
- lappend contents [list $mime_disposition $content]
- }
- } else {
- # Defaults
- return {
- "text/plain; charset=us-ascii"
- "An OpenACS object was unable to be encoded here.\n"
- }
- }
-
- set content_type \
- "multipart/[acs_mail_multipart_type $content_item_id]; boundary=\"$boundary\""
- set content ""
- foreach {cont} $contents {
- set c_disp [lindex $cont 0]
- set c_type [lindex [lindex $cont 1] 0]
- set c_cont [lindex [lindex $cont 1] 1]
- append content "--$boundary\n"
- append content "Content-Type: $c_type\n"
- if { [string first "text" $c_type] != 0 } {
- # not a text item: therefore base64
- append content "Content-Transfer-Encoding: base64\n"
- }
- append content "Content-Disposition: $c_disp\n"
- append content "\n"
- append content $c_cont
- append content "\n\n"
- }
- append content "--$boundary--\n"
- return [list $content_type $content]
- }
-
- # Defaults
- return {
- "text/plain; charset=us-ascii"
- "An OpenACS object was unable to be encoded here.\n"
- }
+ if { $storage_type eq "file" } {
+ ns_log Debug "acs-mail: encode: file $content_item_id"
+ set encoded_content [acs_mail_uuencode_file [cr_fs_path]$content]
+ } else {
+ ns_log Debug "acs-mail: encode: lob $content_item_id"
+ # Blob. Now we need to decide if this is binary
+ # so we can uuencode it if necessary.
+ # We'll use the mime type to decide
+
+ if { [string first "text" $v_content_type] == 0 } {
+ ns_log Debug "acs-mail: encode: plain content"
+ set encoded_content "$content"
+ } else {
+ # binary content - copy the blob to temp file
+ # that we will then uuencode
+ set file [ns_tmpnam]
+ db_blob_get_file copy_blob_to_file "
+ select r.content, i.storage_type
+ from cr_revisions r, cr_items i
+ where r.revision_id = $revision_id and
+ r.item_id = i.item_id " -file $file
+ ns_log Debug "acs-mail: encode: binary content"
+ set encoded_content [acs_mail_uuencode_file $file]
+ }
+ }
+
+ return [list $v_content_type $encoded_content]
+ }
+ }
+ } else {
+ # Harder. Oops.
+ ns_log Debug "acs-mail: encode: multipart $content_item_id"
+ set boundary "=-=-="
+ set contents {}
+ # Get the component pieces
+ set multipart_list [db_list_of_lists acs_mail_body_to_mime_get_contents {
+ select mime_filename, mime_disposition, content_item_id as ci_id
+ from acs_mail_multipart_parts
+ where multipart_id = :content_item_id
+ order by sequence_number
+ }
+ ]
+
+ if { $multipart_list ne "" } {
+ foreach multipart_item $multipart_list {
+ set mime_filename [lindex $multipart_item 0]
+ set mime_disposition [lindex $multipart_item 1]
+ set ci_id [lindex $multipart_item 2]
+
+ if { $mime_disposition eq "" } {
+ if { $mime_filename ne "" } {
+ set mime_disposition "attachment; filename=$mime_filename"
+ } else {
+ set mime_disposition "inline"
+ }
+ } else {
+ if { $mime_filename ne "" } {
+ set mime_disposition \
+ "$mime_disposition; filename=$mime_filename"
+ }
+ }
+ set content [acs_mail_encode_content $ci_id]
+ while {[regexp -- "--$boundary--" $content]} {
+ set boundary "=$boundary"
+ }
+ lappend contents [list $mime_disposition $content]
+ }
+ } else {
+ # Defaults
+ return {
+ "text/plain; charset=us-ascii"
+ "An OpenACS object was unable to be encoded here.\n"
+ }
+ }
+
+ set content_type \
+ "multipart/[acs_mail_multipart_type $content_item_id]; boundary=\"$boundary\""
+ set content ""
+ foreach {cont} $contents {
+ set c_disp [lindex $cont 0]
+ set c_type [lindex [lindex $cont 1] 0]
+ set c_cont [lindex [lindex $cont 1] 1]
+ append content "--$boundary\n"
+ append content "Content-Type: $c_type\n"
+ if { [string first "text" $c_type] != 0 } {
+ # not a text item: therefore base64
+ append content "Content-Transfer-Encoding: base64\n"
+ }
+ append content "Content-Disposition: $c_disp\n"
+ append content "\n"
+ append content $c_cont
+ append content "\n\n"
+ }
+ append content "--$boundary--\n"
+ return [list $content_type $content]
+ }
+
+ # Defaults
+ return {
+ "text/plain; charset=us-ascii"
+ "An OpenACS object was unable to be encoded here.\n"
+ }
}
ad_proc -private acs_mail_body_to_output_format {
@@ -354,11 +354,11 @@
so the info can easily be handed to ns_sendmail (for now.)
} {
- if [string equal $body_id ""] {
+ if { $body_id eq "" } {
db_1row acs_mail_body_to_mime_get_body {
select body_id from acs_mail_links where mail_link_id = :link_id
}
- }
+ }
db_1row acs_mail_body_to_mime_data {
select header_message_id, header_reply_to, header_subject,
header_from, header_to, content_item_id
@@ -367,15 +367,15 @@
}
set headers [ns_set new]
ns_set put $headers "Message-Id" "<$header_message_id>"
- # taking these out because they are redundant and
- # could conflict with the values in acs_mail_queue_outgoing
+ # taking these out because they are redundant and
+ # could conflict with the values in acs_mail_queue_outgoing
# if ![string equal $header_to ""] {
# ns_set put $headers "To" $header_to
# }
# if ![string equal $header_from ""] {
# ns_set put $headers "From" $header_from
# }
- if ![string equal $header_reply_to ""] {
+ if { $header_reply_to ne "" } {
ns_set put $headers "In-Reply-To" $header_reply_to
}
ns_set put $headers "MIME-Version" "1.0"
@@ -410,7 +410,7 @@
from acs_mail_queue_outgoing
} {
set to_send [acs_mail_body_to_output_format -link_id $message_id]
- set to_send_2 [list $envelope_to $envelope_from [lindex $to_send 2] [lindex $to_send 3] [lindex $to_send 4]]
+ set to_send_2 [list $envelope_to $envelope_from [lindex $to_send 2] [lindex $to_send 3] [lindex $to_send 4]]
if [catch {
eval ns_sendmail $to_send_2
@@ -442,10 +442,10 @@
## acs_mail_content
ad_proc -private acs_mail_content_new {
- {-body_id:required}
+ {-body_id:required}
{-creation_user ""}
{-creation_ip ""}
- {-header_subject ""}
+ {-header_subject ""}
{-content}
{-content_file}
{-content_type ""}
@@ -461,14 +461,14 @@
} {
if [info exists content] {
set item_id [acs_mail_set_content -body_id $body_id \
- -header_subject $header_subject \
- -creation_user $creation_user -creation_ip $creation_ip \
- -content $content -content_type $content_type]
+ -header_subject $header_subject \
+ -creation_user $creation_user -creation_ip $creation_ip \
+ -content $content -content_type $content_type]
} elseif [info exists content_file] {
set item_id [acs_mail_set_content_file -body_id $body_id \
- -header_subject $header_subject \
- -creation_user $creation_user -creation_ip $creation_ip \
- -content_file $content_file -content_type $content_type]
+ -header_subject $header_subject \
+ -creation_user $creation_user -creation_ip $creation_ip \
+ -content_file $content_file -content_type $content_type]
}
return $item_id
@@ -497,7 +497,7 @@
If content or content_file is supplied, a content object will
automatically be created and set as the content object for the new body.
} {
- set body_id [db_exec_plsql acs_mail_body_new {
+ set body_id [db_exec_plsql acs_mail_body_new {
begin
:1 := acs_mail_body.new (
body_id => :body_id,
@@ -520,18 +520,18 @@
set content_item_id \
[acs_mail_content_new -body_id $body_id \
-creation_user $creation_user -creation_ip $creation_ip \
- -header_subject $header_subject \
+ -header_subject $header_subject \
-content $content -content_type $content_type]
} elseif {[info exists content_file]} {
set content_item_id \
[acs_mail_content_new -body_id $body_id \
-creation_user $creation_user -creation_ip $creation_ip \
- -header_subject $header_subject \
+ -header_subject $header_subject \
-content_file $content_file -content_type $content_type]
}
- acs_mail_body_set_content_object -body_id $body_id \
- -content_item_id $content_item_id
+ acs_mail_body_set_content_object -body_id $body_id \
+ -content_item_id $content_item_id
return $body_id
}
@@ -553,7 +553,7 @@
of an already-existing acs_mail_body
} {
# empty is okay (handled by notnull)
- if [empty_string_p $value] {
+ if { $value eq "" } {
return 1
}
if ![acs_mail_body_p $value] {
@@ -640,8 +640,8 @@
Returns the subtype of the multipart.
} {
db_1row acs_mail_multipart_type {
- select multipart_kind from acs_mail_multiparts
- where multipart_id = :object_id
+ select multipart_kind from acs_mail_multiparts
+ where multipart_id = :object_id
}
return $multipart_kind;
}
@@ -665,7 +665,7 @@
of an already-existing acs_mail_multipart
} {
# empty is okay (handled by notnull)
- if [empty_string_p $value] {
+ if { $value eq "" } {
return 1
}
if ![acs_mail_multipart_p $value] {
@@ -721,7 +721,7 @@
} elseif {[info exists content_item_id]} {
set body_id [acs_mail_body_new -creation_user $creation_user \
-creation_ip $creation_ip \
- -content_item_id $content_item_id]
+ -content_item_id $content_item_id]
} else {
# Uh oh... Use a blank one, I guess. Not so good.
set body_id [acs_mail_body_new -creation_user $creation_user \
@@ -746,7 +746,7 @@
Returns the object_id of the acs_mail_body for this mail link.
} {
return [db_string acs_mail_link_get_body_id {
- select body_id from acs_mail_links where mail_link_id = :link_id
+ select body_id from acs_mail_links where mail_link_id = :link_id
}]
}
@@ -767,7 +767,7 @@
of an already-existing acs_mail_link
} {
# empty is okay (handled by notnull)
- if [empty_string_p $value] {
+ if { $value eq "" } {
return 1
}
if ![acs_mail_link_p $value] {
Index: openacs-4/packages/acs-subsite/lib/user-new.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-subsite/lib/user-new.tcl,v
diff -u -r1.21 -r1.22
--- openacs-4/packages/acs-subsite/lib/user-new.tcl 1 Oct 2017 12:16:05 -0000 1.21
+++ openacs-4/packages/acs-subsite/lib/user-new.tcl 23 Apr 2018 15:19:32 -0000 1.22
@@ -2,10 +2,10 @@
ADP include for adding new users
Expects parameters:
-
+
@param self_register_p Is the form for users who self register (1) or
for administrators who create oher users (0)?
-
+
@param next_url Any url to redirect to after the form has been
submitted. The variables user_id,
password, and account_messages will be
@@ -22,7 +22,7 @@
an element to the form where the user can
pick a relation among the permissible
rel-types for the group. Can be empty.
-
+
} {
{self_register_p:boolean 1}
{next_url ""}
@@ -39,10 +39,10 @@
security::require_secure_conn
}
-# Log user out if currently logged in, if specified in the includeable chunk's parameters,
+# Log user out if currently logged in, if specified in the includeable chunk's parameters,
# e.g. not when creating accounts for other users
if { $self_register_p } {
- ad_user_logout
+ ad_user_logout
}
# Redirect to the registration assessment if there is one, if not, continue with the regular
@@ -68,7 +68,7 @@
#
set validate {
{email
- {[string equal "" [party::get_by_email -email $email]]}
+ {[party::get_by_email -email $email] eq ""}
"[_ acs-subsite.Email_already_exists]"
}
}
@@ -80,7 +80,7 @@
ad_form -extend -name register -form {
{rel_group_id:integer(hidden),optional}
}
-
+
if { [permission::permission_p -object_id $rel_group_id -privilege "admin"] } {
ad_form -extend -name register -form {
{rel_type:text(select)
@@ -105,9 +105,9 @@
ad_form -extend -name register -on_request {
# Populate elements from local variables
-
+
} -on_submit {
-
+
db_transaction {
array set creation_info [auth::create_user \
-user_id $user_id \
@@ -122,17 +122,17 @@
-url $url \
-secret_question $secret_question \
-secret_answer $secret_answer]
-
+
if { $creation_info(creation_status) eq "ok" && $rel_group_id ne "" } {
group::add_member \
-group_id $rel_group_id \
-user_id $user_id \
-rel_type $rel_type
}
}
-
+
# Handle registration problems
-
+
switch -- $creation_info(creation_status) {
ok {
# Continue below
@@ -144,71 +144,71 @@
set first_elm [lindex [concat $reg_elms(required) $reg_elms(optional)] 0]
form set_error register $first_elm $creation_info(creation_message)
}
-
+
# Element messages
foreach { elm_name elm_error } $creation_info(element_messages) {
form set_error register $elm_name $elm_error
}
break
}
}
-
+
switch -- $creation_info(account_status) {
ok {
# Continue below
}
default {
- if {[parameter::get -parameter RegistrationRequiresEmailVerificationP -default 0] &&
- $creation_info(account_status) eq "closed"} {
- ad_return_warning "Email Validation is required" $creation_info(account_message)
- ad_script_abort
- }
- if {[parameter::get -parameter RegistrationRequiresApprovalP -default 0] &&
- $creation_info(account_status) eq "closed"} {
- ad_return_warning "Account approval is required" $creation_info(account_message)
- ad_script_abort
- }
+ if {[parameter::get -parameter RegistrationRequiresEmailVerificationP -default 0] &&
+ $creation_info(account_status) eq "closed"} {
+ ad_return_warning "Email Validation is required" $creation_info(account_message)
+ ad_script_abort
+ }
+ if {[parameter::get -parameter RegistrationRequiresApprovalP -default 0] &&
+ $creation_info(account_status) eq "closed"} {
+ ad_return_warning "Account approval is required" $creation_info(account_message)
+ ad_script_abort
+ }
# Display the message on a separate page
ad_returnredirect \
-message $creation_info(account_message) \
-html \
- "[subsite::get_element -element url]register/account-closed"
+ "[subsite::get_element -element url]register/account-closed"
ad_script_abort
}
}
-
+
} -after_submit {
-
+
if { $next_url ne "" } {
# Add user_id and account_message to the URL
-
+
ad_returnredirect [export_vars -base $next_url {user_id password {account_message $creation_info(account_message)}}]
ad_script_abort
- }
-
-
+ }
+
+
# User is registered and logged in
if { $return_url eq "" } {
# Redirect to subsite home page.
set return_url [subsite::get_element -element url]
}
-
+
# If the user is self registering, then try to set the preferred
# locale (assuming the user has set it as a anonymous visitor
# before registering).
if { $self_register_p } {
- # We need to explicitly get the cookie and not use
- # lang::user::locale, as we are now a registered user,
- # but one without a valid locale setting.
- set locale [ad_get_cookie "ad_locale"]
- if { $locale ne "" } {
- lang::user::set_locale $locale
- ad_set_cookie -replace t -max_age 0 "ad_locale" ""
- }
+ # We need to explicitly get the cookie and not use
+ # lang::user::locale, as we are now a registered user,
+ # but one without a valid locale setting.
+ set locale [ad_get_cookie "ad_locale"]
+ if { $locale ne "" } {
+ lang::user::set_locale $locale
+ ad_set_cookie -replace t -max_age 0 "ad_locale" ""
+ }
}
-
+
# Handle account_message
if { $creation_info(account_message) ne "" && $self_register_p } {
# Only do this if user is self-registering
Index: openacs-4/packages/acs-subsite/tcl/subsite-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-subsite/tcl/subsite-procs.tcl,v
diff -u -r1.51 -r1.52
--- openacs-4/packages/acs-subsite/tcl/subsite-procs.tcl 23 Apr 2018 07:14:16 -0000 1.51
+++ openacs-4/packages/acs-subsite/tcl/subsite-procs.tcl 23 Apr 2018 15:19:32 -0000 1.52
@@ -15,7 +15,7 @@
namespace eval default {}
}
-ad_proc -public subsite::after_mount {
+ad_proc -public subsite::after_mount {
{-package_id:required}
{-node_id:required}
} {
@@ -31,7 +31,7 @@
-ad_proc -public subsite::before_uninstantiate {
+ad_proc -public subsite::before_uninstantiate {
{-package_id:required}
} {
@@ -41,7 +41,7 @@
subsite::default::delete_app_group -package_id $package_id
}
-ad_proc -public subsite::before_upgrade {
+ad_proc -public subsite::before_upgrade {
{-from_version_name:required}
{-to_version_name:required}
} {
@@ -64,16 +64,16 @@
-package_id $main_site_id \
-parameter ApprovalExpirationDays \
-default 0]
-
+
parameter::set_value \
-package_id [ad_acs_kernel_id] \
-parameter PasswordExpirationDays \
-value [parameter::get \
-package_id $main_site_id \
-parameter PasswordExpirationDays \
-default 0]
-
-
+
+
apm_parameter_unregister \
-package_key acs-subsite \
-parameter ApprovalExpirationDays \
@@ -121,7 +121,7 @@
<ul>
<li> Create application group
<li> Create segment "Subsite Users"
- <li> Create relational constraint to make subsite registration
+ <li> Create relational constraint to make subsite registration
require supersite registration.
</ul>
@@ -179,7 +179,7 @@
-object_id $package_id \
-privilege $privilege
}
-
+
}
}
@@ -197,8 +197,8 @@
ad_proc -private subsite::instance_name_exists_p {
node_id
- instance_name
-} {
+ instance_name
+} {
Returns 1 if the instance_name exists at this node. 0
otherwise. Note that the search is case-sensitive.
@@ -212,7 +212,7 @@
}]
}
-ad_proc -public subsite::auto_mount_application {
+ad_proc -public subsite::auto_mount_application {
{ -instance_name "" }
{ -pretty_name "" }
{ -node_id "" }
@@ -238,7 +238,7 @@
@see site_node::instantiate_and_mount
- @return The package id of the newly mounted package
+ @return The package id of the newly mounted package
} {
if { $node_id eq "" } {
@@ -363,7 +363,7 @@
@author Hector Amado (hr_amado@galileo.edu)
@creation-date 2004-06-16
} {
-
+
set package_id [ad_conn subsite_id]
if { ![parameter::get -package_id $package_id -parameter SolicitPortraitP -default 1] } {
@@ -426,7 +426,7 @@
@param object_type
} {
return [db_string select_pretty_name {
- select pretty_name from acs_object_types
+ select pretty_name from acs_object_types
where object_type = :object_type
}]
}
@@ -435,7 +435,7 @@
return_url_list
} {
Given a list of return_urls, we recursively encode them into one
- return_url that can be redirected to or passed into a page. As long
+ return_url that can be redirected to or passed into a page. As long
as each page in the list does the typical redirect to return_url, then
the page flow will go through each of the pages in $return_url_list
} {
@@ -545,8 +545,8 @@
} {
set info(url) "[string range $info(url) 0 [string last / $info(url)]]."
}
-
- if { [ad_conn node_id] ==
+
+ if { [ad_conn node_id] ==
[site_node::closest_ancestor_package -include_self \
-package_key [subsite::package_keys] \
-url [ad_conn url]] } {
@@ -562,13 +562,13 @@
} {
set current_url "[string range $current_url 0 [string last / $current_url]]."
}
-
+
set info(url) [file join $info(folder) $info(url)]
regsub {/\.$} $info(url) / info(url)
# Default to not selected
set selected_p 0
-
+
if { $current_url eq $info(url) || $info(name) eq $section } {
set selected_p 1
} else {
@@ -580,9 +580,9 @@
}
}
}
-
- set link_p [expr {$current_url ne $info(url) }]
-
+
+ set link_p [expr {$current_url ne $info(url) }]
+
template::multirow append $multirow \
$info(name) \
$info(label) \
@@ -662,7 +662,7 @@
for { set i 0 } { $i < [llength $child_urls] } { incr i } {
array set child_node [site_node::get_from_url -exact -url [lindex $child_urls $i]]
if { $index_redirect_url eq $child_node(url) ||
- [string equal ${index_redirect_url}/ $child_node(url)]} {
+ ${index_redirect_url}/ eq $child_node(url)} {
lappend pageflow $child_node(name) [list \
label "Home" \
folder $child_node(name) \
@@ -769,7 +769,7 @@
@author Peter Marklund
} {
array set main_node [site_node::get_from_url -url "/"]
-
+
return $main_node(object_id)
}
@@ -825,7 +825,7 @@
parameter::set_value -parameter StreamingHead -package_id $subsite_id \
-value $streaming_head
-
+
callback subsite::theme_changed \
-subsite_id $subsite_id \
-old_theme $old_theme \
@@ -839,7 +839,7 @@
} {
Callback for executing code after the subsite theme has been send changed
-
+
@param subsite_id subsite, of which the theme was changed
@param old_theme the old theme
@param new_theme the new theme
@@ -850,15 +850,15 @@
-theme:required
-subsite_id
-unmodified:boolean
-} {
+} {
Returns a list of all packages implementing subsite that are
currently using specified theme. Optionally, returns a list of
just those that were not locally modified.
@param theme theme key to lookup for.
@param subsite_id narrow search to this subsite only. Useful to
check whether a single subsite is using a theme with or without
- local modifications.
+ local modifications.
@param unmodified decides whether we include subsites which theme
was locally modified.
@@ -883,7 +883,7 @@
select * from subsite_themes
where key = :theme
}
-
+
set settings {
template DefaultMaster
css ThemeCSS
@@ -907,7 +907,7 @@
set default [string trim [set $var]]
set value [string trim [parameter::get -parameter $param -package_id $subsite_id]]
regsub -all {\r\n} $value "\n" value
- regsub -all {\r\n} $default "\n" default
+ regsub -all {\r\n} $default "\n" default
set collect_p [expr {$default eq $value}]
if {!$collect_p} {
ns_log notice "theme '$theme' parameter $var differs on subsite '$subsite_id': default '$default' actual value '$value'"
@@ -932,10 +932,10 @@
currently using specified theme. This might be used, for example,
in upgrade callbacks for themes if desired behavior is to upgrade
all subsites using it without manual intervention.
-
+
By default this proc will not refresh locally modified templates.
-
- @param theme theme key to lookup for
+
+ @param theme theme key to lookup for
@param include_modified force reload also for locally modified
templates
} {
@@ -951,7 +951,7 @@
ad_proc -public subsite::save_theme_parameters {
-subsite_id
-theme
- -local_p
+ -local_p
} {
Save the actual theming parameter set of the given/current subsite
as default for the given/current theme. These default values are
@@ -989,7 +989,7 @@
-resource_dir [parameter::get -parameter ResourceDir -package_id $subsite_id] \
-streaming_head [parameter::get -parameter StreamingHead -package_id $subsite_id] \
-local_p $local_p
-
+
}
ad_proc -public subsite::save_theme_parameters_as {
@@ -1029,7 +1029,7 @@
-resource_dir [parameter::get -parameter ResourceDir -package_id $subsite_id] \
-streaming_head [parameter::get -parameter StreamingHead -package_id $subsite_id] \
-local_p true
-
+
}
@@ -1045,7 +1045,7 @@
if { ![info exists subsite_id] } {
set subsite_id [ad_conn subsite_id]
}
- parameter::get -parameter ThemeKey -package_id $subsite_id
+ parameter::get -parameter ThemeKey -package_id $subsite_id
}
ad_proc -public subsite::new_subsite_theme {
@@ -1066,7 +1066,7 @@
} {
# the following line is for Oracle compatibility
set local_p [expr {$local_p ? "t" : "f"}]
-
+
db_dml insert_subsite_theme {}
}
@@ -1090,7 +1090,7 @@
} {
# the following line is for Oracle compatibility
set local_p [expr {$local_p ? "t" : "f"}]
-
+
db_dml update {
update subsite_themes
set name = :name,
@@ -1114,7 +1114,7 @@
ad_proc -public subsite::delete_subsite_theme {
-key:required
} {
- Delete a subsite theme, making it unavailable to the theme configuration code.
+ Delete a subsite theme, making it unavailable to the theme configuration code.
} {
db_dml delete_subsite_theme {}
}
@@ -1187,7 +1187,7 @@
}
set request_vhost_p [expr {$main_host ne $driver_info(vhost) }]
-
+
} elseif {$node_id eq ""} {
error "You must supply node_id when not connected."
} else {
@@ -1208,14 +1208,14 @@
if {$protocol eq ""} {
set protocol $driver_info(proto)
}
-
+
#
# If the provided port is empty, get it from the driver_info.
#
if {$port eq ""} {
set port $driver_info(port)
}
-
+
#
# If the provided host is not empty, get it from the host header
# field (when connected) or from the configured host name.
@@ -1232,14 +1232,14 @@
set host $driver_info(hostname)
}
-
+
set result ""
if { $request_vhost_p } {
- set root_p [string equal $subsite_node(parent_id) ""]
+ set root_p [expr {$subsite_node(parent_id) eq ""}]
set search_vhost $host
set where_clause [db_map orderby]
-
+
# TODO: This should be cached
set site_node $subsite_node(node_id)
set mapped_vhost [db_string get_vhost {} -default ""]