- Import messages for a certain locale and package from a given XML + Import messages for a certain locale and package from a given XML catalog file to the database. This procedure invokes lang::catalog::parse to read the catalog file and lang::message::register to register the messages with the system (updates database and cache). @@ -555,14 +555,14 @@ @param file_path The absolute path of the XML file to import messages from. The path must be on valid format, see apm_is_catalog_file - @return An array list containing the number of messages processed, number of messages added, + @return An array list containing the number of messages processed, number of messages added, number of messages updated, and the number of messages deleted by the import. The keys of the array list are processed, added, updated, and deleted. @see lang::catalog::parse @see lang::message::register @see lang::catalog::import_messages - + @author Peter Marklund } { # Check arguments @@ -625,7 +625,7 @@ Import a given set of messages from a catalog file to the database for a certain package and locale. If we already have messages in the db for the given package and locale then a merge - between the database messages and the file messages will be performed. + between the database messages and the file messages will be performed.
@@ -649,13 +649,13 @@
What follows below is a description of the logic of the proc in terms of its input, the cases considered, and the logical actions taken for each case. -
+- There are three sets of keys, file, db, and base keys. For each key in + There are three sets of keys, file, db, and base keys. For each key in the union of these keys there are three messages that can exist: the file message, the db message, and the base message. The base message serves as the base for the merge. We will distinguish all the different permutations - of each of the three messages existing or not, and all permutations of the messages being different from eachother. + of each of the three messages existing or not, and all permutations of the messages being different from eachother. We don't distinguish how two messages are different, only whether they are different or not. In total that gives us 14 cases (permutations) to consider.
@@ -696,15 +696,15 @@ 14. All different. upgrade_action=update, conflict_p=t - @param file_messages_list An array list with message keys as keys and - the message of those keys as values, + @param file_messages_list An array list with message keys as keys and + the message of those keys as values, i.e. (key, value, key, value, ...) @param package_key The package_key for the messages. @param locale The locale of the messages. - @return An array list containing the number of messages processed, number of messages added, + @return An array list containing the number of messages processed, number of messages added, number of messages updated, number of messages deleted by the import, and a list of errors produced. The keys of the array list are processed, added, updated, and deleted, and errors. @@ -737,13 +737,13 @@ # Remember each time we've processed a key, so we don't process it twice array set message_key_processed_p [list] - # Loop over the union of import and db keys. + # Loop over the union of import and db keys. foreach message_key [lsort [concat [array names db_messages] [array names file_messages] [array names base_messages]]] { if { [info exists message_key_processed_p($message_key)] } { continue } set message_key_processed_p($message_key) 1 - + ########################################### # # Figure out how db and file messages have changed with regards to the base message @@ -794,8 +794,8 @@ ########################################### # - # Based on the change in file and db messages, - # and based on whether file and db messages differ, decide + # Based on the change in file and db messages, + # and based on whether file and db messages differ, decide # which upgrade actions to take # ########################################### @@ -831,7 +831,7 @@ } add { switch $file_change { - none {} + none {} add { if { $db_messages($message_key) ne $file_messages($message_key) } { # case 8 @@ -841,7 +841,7 @@ set conflict_p "t" } } - } + } } update { switch $file_change { @@ -862,7 +862,7 @@ set upgrade_status "deleted" set conflict_p "t" } - } + } } delete { switch $file_change { @@ -877,7 +877,7 @@ delete { # case 1 set import_case 1 - # deletion in both db and file + # deletion in both db and file # no status change, no conflict # sync time should be updated below } @@ -889,12 +889,12 @@ # # Execute upgrade actions # - ########################################### + ########################################### - # For certain messages we need to move the sync point so that we have a current base for the next upgrade. + # For certain messages we need to move the sync point so that we have a current base for the next upgrade. if { $db_change eq "none" || $file_change ne "none" } { - # If there is no db change then any change in the file will be reflected in - # db (file takes precedence) and file and db are identical. + # If there is no db change then any change in the file will be reflected in + # db (file takes precedence) and file and db are identical. # Also, regardless of what's happened in db, if # there has been a change in the file then that change will take effect in # the db and file and db are again identical (in sync). @@ -932,7 +932,7 @@ set edit_array(deleted_p) [string equal $upgrade_status "deleted"] set edit_array(conflict_p) $conflict_p } - + ns_log Debug "lang::catalog::import_messages - invoking lang::message::edit with import_case=\"$import_case\" -update_sync=$update_sync_p $message_key [array get edit_array]" ad_try { lang::message::edit \ @@ -953,7 +953,7 @@ if { ! $error_p } { incr message_count($upgrade_status) } - } + } incr message_count(processed) } ;# End of message key loop @@ -977,7 +977,7 @@ @param initialize Only load messages from packages that have never before had any message imported @param cache Provide this switch if you want the proc to cache all the imported messages - @return An array list containing the number of messages processed, number of messages added, + @return An array list containing the number of messages processed, number of messages added, number of messages updated, number of messages deleted by the import, and a list of errors produced. The keys of the array list are processed, added, updated, and deleted, and errors. @@ -1073,7 +1073,7 @@ # Get all catalog files for enabled locales set catalog_files [list] - foreach locale $locales_list { + foreach locale $locales_list { # If we are only processing certain locales and this is not one of them - continue if { [llength $locales] > 0 && $locale ni $locales } { @@ -1134,10 +1134,10 @@ # ################## -ad_proc -private lang::catalog::translate {} { +ad_proc -private lang::catalog::translate {} { Translates all untranslated strings in a message catalog from English into Spanish, French and German - using Babelfish. NOTE: this proc is unmaintained. + using Babelfish. NOTE: this proc is unmaintained. Quick way to get a multilingual site up and running if you can live with the quality of the translations.@@ -1148,7 +1148,7 @@ } { set default_locale [parameter::get -package_id [apm_package_id_from_key acs-lang] -parameter SiteWideLocale] - db_foreach get_untranslated_messages {} { + db_foreach get_untranslated_messages {} { foreach lang [list es_ES fr_FR de_DE] { ad_try { set translated_message [lang_babel_translate $message en_$lang] @@ -1158,7 +1158,7 @@ lang::message::register $lang $package_key $message_key $translated_message } } - } + } } # Local variables: Index: openacs-4/packages/acs-lang/tcl/localization-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-lang/tcl/localization-procs.tcl,v diff -u -r1.26 -r1.27 --- openacs-4/packages/acs-lang/tcl/localization-procs.tcl 29 Dec 2017 11:13:40 -0000 1.26 +++ openacs-4/packages/acs-lang/tcl/localization-procs.tcl 29 Dec 2017 11:17:34 -0000 1.27 @@ -8,20 +8,20 @@ http://www.fsf.org/copyleft/gpl.html @creation-date 30 September 2000 - @author Jeff Davis (davis@xarg.net) + @author Jeff Davis (davis@xarg.net) @author Ashok Argent-Katwala (akatwala@arsdigita.com) @cvs-id $Id$ } -ad_proc -public lc_parse_number { - num - locale +ad_proc -public lc_parse_number { + num + locale {integer_only_p 0} } { - Converts a number to its canonical - representation by stripping everything but the - decimal separator and triming left 0's so it + Converts a number to its canonical + representation by stripping everything but the + decimal separator and triming left 0's so it won't be octal. It can process the following types of numbers:
- Takes a grouping specifier and - inserts the given separator into the string. - Given a separator of : + Takes a grouping specifier and + inserts the given separator into the string. + Given a separator of : and a number of 123456789 it returns:
grouping Formatted Value
- {3 -1} 123456:789
- {3} 123:456:789
- {3 2 -1} 1234:56:789
- {3 2} 12:34:56:789
- {-1} 123456789
+ {3 -1} 123456:789
+ {3} 123:456:789
+ {3 2 -1} 1234:56:789
+ {3 2} 12:34:56:789
+ {-1} 123456789
@param num Number
@@ -132,52 +132,52 @@
@param num_re Regular expression for valid numbers
@return Number formatted with thousand separator
} {
- # with empty separator or grouping string we behave
+ # with empty separator or grouping string we behave
# posixly
- if {$grouping eq "" || $sep eq "" } {
+ if {$grouping eq "" || $sep eq "" } {
return $num
}
-
+
# we need to sanitize the subspec
regsub -all -- "(\[&\\\\\])" $sep "\\\\\\1" sep
set match "^(-?$num_re+)("
set group [lindex $grouping 0]
-
- while { $group > 0} {
+
+ while { $group > 0} {
set re "$match[string repeat $num_re $group])"
- if { ![regsub -- $re $num "\\1$sep\\2" num] } {
- break
- }
- if {[llength $grouping] > 1} {
+ if { ![regsub -- $re $num "\\1$sep\\2" num] } {
+ break
+ }
+ if {[llength $grouping] > 1} {
set grouping [lrange $grouping 1 end]
}
set group [lindex $grouping 0]
- }
-
- return $num
+ }
+
+ return $num
}
ad_proc -public lc_numeric {
- num
- {fmt {}}
+ num
+ {fmt {}}
{locale ""}
-} {
+} {
Given a number and a locale return a formatted version of the number
for that locale.
@param num Number in canonical form
- @param fmt Format string used by the Tcl format
+ @param fmt Format string used by the Tcl format
command (should be restricted to the form "%.Nf" if present).
@param locale Locale
@return Localized form of the number
-} {
- if {$fmt ne ""} {
+} {
+ if {$fmt ne ""} {
set out [format $fmt $num]
- } else {
+ } else {
set out $num
}
@@ -191,9 +191,9 @@
set sep ,
set dec .
set grouping 3
-
+
}
-
+
regsub {\.} $out $dec out
return [lc_sepfmt $out $grouping $sep]
}
@@ -202,7 +202,7 @@
seconds
} {
Convert a time in the Tcl internal clock seeconds format to ANSI format, usable by lc_time_fmt.
-
+
@author Lars Pind (lars@pinds.com)
@return ANSI (YYYY-MM-DD HH24:MI:SS) formatted date.
@see lc_time_fmt
@@ -231,17 +231,17 @@
}
ad_proc -public lc_time_fmt {
- datetime
- fmt
+ datetime
+ fmt
{locale ""}
} {
- Formats a time for the specified locale.
+ Formats a time for the specified locale.
@param datetime Strictly in the form "YYYY-MM-DD HH24:MI:SS".
- Formulae for calculating day of week from the Calendar FAQ
+ Formulae for calculating day of week from the Calendar FAQ
(http://www.tondering.dk/claus/calendar.html)
@param fmt An ISO 14652 LC_TIME style formatting string. The highlighted functions localize automatically based on the user's locale; other strings will use locale-specific text but not necessarily locale-specific formatting.
-
+
%a FDCC-set's abbreviated weekday name.
%A FDCC-set's full weekday name.
%b FDCC-set's abbreviated month name.
@@ -268,7 +268,7 @@
%n A character.
%p FDCC-set's equivalent of either AM or PM.
%r Hours and minutes using 12-hour clock AM/PM
- notation, e.g. '06:12 AM'.
+ notation, e.g. '06:12 AM'.
%q Long date without weekday (OpenACS addition to the standard)
%Q Long date with weekday (OpenACS addition to the standard)
%S Seconds as a decimal number (00-61).
@@ -294,7 +294,7 @@
@error Fails if given a non-existent locale or a malformed datetime
Doesn't check for impossible dates. Ask it for 29 Feb 1999 and it will tell you it was a Monday
(1st March was a Monday, it wasn't a leap year). Also it only works with the Gregorian calendar -
- but that's reasonable, but could be a problem if you are running a seriously historical site
+ but that's reasonable, but could be a problem if you are running a seriously historical site
(or have an 'on this day in history' style page that goes back a good few hundred years).
@return A date formatted for a locale
} {
@@ -305,38 +305,38 @@
if { $locale eq "" } {
set locale [ad_conn locale]
}
-
+
# Some initialisation...
# Now, expect d_fmt, t_fmt and d_t_fmt to exist of the form in ISO spec
# Rip $date into $lc_time_* as numbers, no leading zeroes
set matchdate {([0-9]{4})\-0?(1?[0-9])\-0?([1-3]?[0-9])}
set matchtime {0?([1-2]?[0-9]):0?([1-5]?[0-9]):0?([1-6]?[0-9])}
set matchfull "$matchdate $matchtime"
-
+
set lc_time_p 1
if {![regexp -- $matchfull $datetime match lc_time_year lc_time_month lc_time_days lc_time_hours lc_time_minutes lc_time_seconds]} {
- if {[regexp -- $matchdate $datetime match lc_time_year lc_time_month lc_time_days]} {
- set lc_time_hours 0
- set lc_time_minutes 0
- set lc_time_seconds 0
- } else {
- error "Invalid date: $datetime"
- }
+ if {[regexp -- $matchdate $datetime match lc_time_year lc_time_month lc_time_days]} {
+ set lc_time_hours 0
+ set lc_time_minutes 0
+ set lc_time_seconds 0
+ } else {
+ error "Invalid date: $datetime"
+ }
}
set lc_time_year [util::trim_leading_zeros $lc_time_year]
-
+
set a [expr {(14 - $lc_time_month) / 12}]
set y [expr {$lc_time_year - $a}]
set m [expr {$lc_time_month + 12*$a - 2}]
-
+
# day_no becomes 0 for Sunday, through to 6 for Saturday. Perfect for addressing zero-based lists pulled from locale info.
set lc_time_day_no [expr {(($lc_time_days + $y + $y/4 - $y/100 + $y/400) + (31 * $m / 12)) % 7}]
-
+
return [subst [util_memoize [list lc_time_fmt_compile $fmt $locale]]]
}
ad_proc -public lc_time_fmt_compile {
- fmt
+ fmt
locale
} {
Compiles ISO 14652 LC_TIME style formatting string to variable substitions and proc calls.
@@ -347,46 +347,46 @@
after local variables have been set.
} {
set to_process $fmt
-
+
set compiled_string ""
while {[regexp -- {^(.*?)%(.)(.*)$} $to_process match done_portion percent_modifier remaining]} {
-
- switch -exact -- $percent_modifier {
- x {
- append compiled_string $done_portion
- set to_process "[lc_get -locale $locale "d_fmt"]$remaining"
- }
- X {
- append compiled_string $done_portion
- set to_process "[lc_get -locale $locale "t_fmt"]$remaining"
- }
- c {
- append compiled_string $done_portion
- set to_process "[lc_get -locale $locale "d_t_fmt"]$remaining"
- }
- q {
- append compiled_string $done_portion
- set to_process "[lc_get -locale $locale "dlong_fmt"]$remaining"
- }
- Q {
- append compiled_string $done_portion
- set to_process "[lc_get -locale $locale "dlongweekday_fmt"]$remaining"
- }
- default {
- append compiled_string "${done_portion}$::lang::util::percent_match($percent_modifier)"
- set to_process $remaining
- }
- }
+
+ switch -exact -- $percent_modifier {
+ x {
+ append compiled_string $done_portion
+ set to_process "[lc_get -locale $locale "d_fmt"]$remaining"
+ }
+ X {
+ append compiled_string $done_portion
+ set to_process "[lc_get -locale $locale "t_fmt"]$remaining"
+ }
+ c {
+ append compiled_string $done_portion
+ set to_process "[lc_get -locale $locale "d_t_fmt"]$remaining"
+ }
+ q {
+ append compiled_string $done_portion
+ set to_process "[lc_get -locale $locale "dlong_fmt"]$remaining"
+ }
+ Q {
+ append compiled_string $done_portion
+ set to_process "[lc_get -locale $locale "dlongweekday_fmt"]$remaining"
+ }
+ default {
+ append compiled_string "${done_portion}$::lang::util::percent_match($percent_modifier)"
+ set to_process $remaining
+ }
+ }
}
-
+
# What is left to_process must be (%.)-less, so it should be included without transformation.
append compiled_string $to_process
-
+
return $compiled_string
}
ad_proc -public lc_time_utc_to_local {
- time_value
+ time_value
{tz ""}
} {
Converts a Universal Time to local time for the specified timezone.
@@ -402,21 +402,21 @@
set local_time $time_value
ad_try {
- set local_time [db_exec_plsql utc_to_local {}]
+ set local_time [db_exec_plsql utc_to_local {}]
} on error {errorMsg} {
ad_log Warning "lc_time_utc_to_local: Query exploded on time conversion from UTC, probably just an invalid date, $time_value: $errorMsg"
}
if {$local_time eq ""} {
- # If no conversion possible, log it and assume local is as given (i.e. UTC)
- ns_log Notice "lc_time_utc_to_local: Timezone adjustment in ad_localization.tcl found no conversion to UTC for $time_value $tz"
+ # If no conversion possible, log it and assume local is as given (i.e. UTC)
+ ns_log Notice "lc_time_utc_to_local: Timezone adjustment in ad_localization.tcl found no conversion to UTC for $time_value $tz"
}
return $local_time
}
ad_proc -public lc_time_local_to_utc {
- time_value
+ time_value
{tz ""}
} {
Converts a local time to a UTC time for the specified timezone.
@@ -431,14 +431,14 @@
set utc_time $time_value
ad_try {
- set utc_time [db_exec_plsql local_to_utc {}]
+ set utc_time [db_exec_plsql local_to_utc {}]
} on error {errorMsg} {
- ad_log Warning "lc_time_local_to_utc: Query exploded on time conversion to UTC, probably just an invalid date, $time_value: $errorMsg"
+ ad_log Warning "lc_time_local_to_utc: Query exploded on time conversion to UTC, probably just an invalid date, $time_value: $errorMsg"
}
if {$utc_time eq ""} {
- # If no conversion possible, log it and assume local is as given (i.e. UTC)
- ns_log Notice "lc_time_local_to_utc: Timezone adjustment in ad_localization.tcl found no conversion to local time for $time_value $tz"
+ # If no conversion possible, log it and assume local is as given (i.e. UTC)
+ ns_log Notice "lc_time_local_to_utc: Timezone adjustment in ad_localization.tcl found no conversion to local time for $time_value $tz"
}
return $utc_time
@@ -448,7 +448,7 @@
ad_proc -public lc_time_system_to_conn {
- time_value
+ time_value
} {
Converts a date from the system (database) to the connection's timezone,
using the OpenACS timezone setting and user's preference
@@ -471,9 +471,9 @@
}
ad_proc -public lc_time_conn_to_system {
- time_value
+ time_value
} {
- Converts a date from the connection's timezone to the system (database) timezone,
+ Converts a date from the connection's timezone to the system (database) timezone,
using the OpenACS timezone setting and user's preference
@param time_value Timestamp from conn input in the ISO datetime format.
@@ -531,9 +531,9 @@
Converts HH24 to HH12.
} {
if {$hours > 12} {
- incr hours -12
+ incr hours -12
} elseif {$hours == 0} {
- set hours 12
+ set hours 12
}
return $hours
}
@@ -543,35 +543,35 @@
to 1(Mon) - 7(Sun)
} {
if {$day_no==0} {
- return 7
+ return 7
} else {
- return $day_no
+ return $day_no
}
}
ad_proc -private lc_time_name_meridian { locale hours } {
Returns locale data depending on AM or PM.
} {
if {$hours > 11} {
- return [lc_get -locale $locale "pm_str"]
+ return [lc_get -locale $locale "pm_str"]
} else {
- return [lc_get -locale $locale "am_str"]
+ return [lc_get -locale $locale "am_str"]
}
}
ad_proc -private lc_leading_space {num} {
Inserts a leading space for numbers less than 10.
} {
if {$num < 10} {
- return " $num"
+ return " $num"
} else {
- return $num
+ return $num
}
}
ad_proc -private lc_leading_zeros {
- the_integer
+ the_integer
n_desired_digits
} {
Adds leading zeros to an integer to give it the desired number of digits
Index: openacs-4/packages/acs-lang/tcl/test/acs-lang-test-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-lang/tcl/test/acs-lang-test-procs.tcl,v
diff -u -r1.20 -r1.21
--- openacs-4/packages/acs-lang/tcl/test/acs-lang-test-procs.tcl 29 Dec 2017 11:13:40 -0000 1.20
+++ openacs-4/packages/acs-lang/tcl/test/acs-lang-test-procs.tcl 29 Dec 2017 11:17:34 -0000 1.21
@@ -44,7 +44,7 @@
$package_name
f
f
-
+
Peter Marklund
Temporary acs-lang test package
@@ -86,9 +86,9 @@
upvar $db_array db_messages
upvar $file_array file_messages
- # Check that we have the expected message properties in the database after upgrade
+ # Check that we have the expected message properties in the database after upgrade
foreach message_key [lsort [array names upgrade_expect]] {
- array set expect_property $upgrade_expect($message_key)
+ array set expect_property $upgrade_expect($message_key)
switch $expect_property(message) {
db {
set expect_message $db_messages($message_key)
@@ -116,7 +116,7 @@
$message_actual(upgrade_status) $expect_property(upgrade_status)
if {$expect_property(sync_time) eq "not_null"} {
aa_true "Import check: $message_key - lang_messages.sync_time not null" \
- [expr {$message_actual(sync_time) ne ""}]
+ [expr {$message_actual(sync_time) ne ""}]
} else {
aa_true "Import check: $message_key - lang_messages.sync_time null" \
[expr {$message_actual(sync_time) eq ""}]
@@ -352,7 +352,7 @@
if { ![info exists base_messages($message_key)]
|| $base_messages($message_key) ne $db_messages($message_key)
} {
- # Added || updated
+ # Added || updated
aa_log "Adding/updating message $message_key"
lang::message::register \
$locale \
@@ -450,7 +450,7 @@
#----------------------------------------------------------------------
aa_log "locale=$locale ----------9. Check results of third upgrade (that resolutions are sticky)----------"
foreach message_key [array names conflict_resolutions] {
-
+
array unset message_array
lang::message::get \
-package_key $package_key \
@@ -467,11 +467,11 @@
aa_register_case \
-procs {
- lang::util::replace_temporary_tags_with_lookups
- lang::catalog::export_messages_to_file
- lang::catalog::parse
- lang::catalog::read_file
- lang::util::get_temporary_tags_indices
+ lang::util::replace_temporary_tags_with_lookups
+ lang::catalog::export_messages_to_file
+ lang::catalog::parse
+ lang::catalog::read_file
+ lang::util::get_temporary_tags_indices
} util__replace_temporary_tags_with_lookups {
A test Tcl file and catalog file are created. The temporary tags in the
@@ -483,7 +483,7 @@
} {
# Peter NOTE: cannot get this test case to work with the rollback code in automated testing
# and couldn't track down why. I'm threrefor resorting to manual teardown which is fragile and hairy
-
+
# The files involved in the test
set package_key acs-lang
set test_dir [lang::test::get_dir]
@@ -498,10 +498,10 @@
# The test messages to use for the catalog file
array set messages_array [list key_1 text_1 key_2 text_2 key_3 text_3]
# NOTE: must be kept up-to-date for teardown to work
- set expected_new_keys [list Auto_Key key_1_1]
+ set expected_new_keys [list Auto_Key key_1_1]
# Write the test Tcl file
- set tcl_file_id [open "$::acs::rootdir/$tcl_file" w]
+ set tcl_file_id [open "$::acs::rootdir/$tcl_file" w]
set new_key_1 "_"
set new_text_1 "Auto Key"
set new_key_2 "key_1"
@@ -536,7 +536,7 @@
array set updated_messages_array $catalog_array(messages)
# Assert that the old messages are unchanged
- foreach old_message_key [array names messages_array] {
+ foreach old_message_key [array names messages_array] {
aa_true "old key $old_message_key should be unchanged" [string equal $messages_array($old_message_key) \
$updated_messages_array($old_message_key)]
}
@@ -547,7 +547,7 @@
# Check that the second new key was made unique and inserted
aa_true "check key made unique" [string equal $updated_messages_array(${new_key_2}_1) $new_text_2]
- # Check that the third key was not inserted
+ # Check that the third key was not inserted
aa_true "third key not inserted" [string equal [lindex [array get updated_messages_array $new_key_3] 1] \
$messages_array($new_key_3)]
@@ -572,12 +572,12 @@
aa_register_case \
-procs {
- lang::util::get_hash_indices
+ lang::util::get_hash_indices
} util__get_hash_indices {
@author Peter Marklund (peter@collaboraid.biz)
@creation-date 21 October 2002
-} {
+} {
set multilingual_string "#package1.key1# abc\# #package2.key2#"
set indices_list [lang::util::get_hash_indices $multilingual_string]
set expected_indices_list [list [list 0 14] [list 21 35]]
@@ -587,19 +587,19 @@
set counter 0
foreach index_item $indices_list {
set expected_index_item [lindex $expected_indices_list $counter]
-
+
aa_true "checking start and end indices of item $counter" \
- [expr {[lindex $index_item 0] eq [lindex $expected_index_item 0]
- && [lindex $index_item 1] eq [lindex $expected_index_item 1]}]
+ [expr {[lindex $index_item 0] eq [lindex $expected_index_item 0]
+ && [lindex $index_item 1] eq [lindex $expected_index_item 1]}]
set counter [expr {$counter + 1}]
}
}
aa_register_case \
-procs {
- lang::util::convert_adp_variables_to_percentage_signs
- lang::util::convert_percentage_signs_to_adp_variables
+ lang::util::convert_adp_variables_to_percentage_signs
+ lang::util::convert_percentage_signs_to_adp_variables
} util__convert_adp_variables_to_percentage_signs {
@author Peter Marklund (peter@collaboraid.biz)
@@ -628,7 +628,7 @@
aa_register_case \
-procs {
- lang::util::replace_adp_text_with_message_tags
+ lang::util::replace_adp_text_with_message_tags
} util__replace_adp_text_with_message_tags {
@author Peter Marklund (peter@collaboraid.biz)
@@ -667,9 +667,9 @@
}
aa_register_case \
- -procs {
- lang::message::format
- } message__format {
+ -procs {
+ lang::message::format
+ } message__format {
@author Peter Marklund (peter@collaboraid.biz)
@creation-date 21 October 2002
@@ -691,9 +691,9 @@
}
aa_register_case \
- -procs {
- lang::message::get_embedded_vars
- } message__get_embedded_vars {
+ -procs {
+ lang::message::get_embedded_vars
+ } message__get_embedded_vars {
@author Peter Marklund (peter@collaboraid.biz)
@creation-date 12 November 2002
@@ -729,22 +729,22 @@
[lang::message::get_embedded_vars $en_us_message]]
if { ![aa_equals "No missing vars" [llength $missing_vars_list] 0] } {
aa_log "Missing vars: $missing_vars_list"
- }
+ }
}
aa_register_case \
- -procs {
- lang::system::set_locale
- lang::system::locale
- lang::system::site_wide_locale
- } locale__test_system_package_setting {
+ -procs {
+ lang::system::set_locale
+ lang::system::locale
+ lang::system::site_wide_locale
+ } locale__test_system_package_setting {
Tests whether the system package level setting works
@author Lars Pind (lars@collaboraid.biz)
@creation-date 2003-08-12
} {
set use_package_level_locales_p_org [parameter::get -parameter UsePackageLevelLocalesP -package_id [apm_package_id_from_key "acs-lang"]]
-
+
parameter::set_value -parameter UsePackageLevelLocalesP -package_id [apm_package_id_from_key "acs-lang"] -value 1
@@ -753,17 +753,17 @@
set locale_to_set [ad_generate_random_string]
set retrieved_locale {}
-
+
ad_try {
# Let's pick a random unmounted package to test with
set package_id [apm_package_id_from_key "acs-kernel"]
-
+
set org_setting [lang::system::site_wide_locale]
-
+
lang::system::set_locale -package_id $package_id $locale_to_set
-
+
set retrieved_locale [lang::system::locale -package_id $package_id]
-
+
} on error {errorMsg} {
# rethrow error
error $errorMsg $::errorInfo
@@ -773,14 +773,14 @@
-package_id [apm_package_id_from_key "acs-lang"] \
-value $use_package_level_locales_p_org
}
-
+
aa_true "Retrieved system locale ('$retrieved_locale') equals the one we just set ('$locale_to_set')" [string equal $locale_to_set $retrieved_locale]
}
aa_register_case \
- -procs {
- lang::conn::browser_locale
- } locale__test_lang_conn_browser_locale {
+ -procs {
+ lang::conn::browser_locale
+ } locale__test_lang_conn_browser_locale {
@author Peter Marklund
@creation-date 2003-08-13
@@ -799,47 +799,47 @@
# First locale is perfect language match
lang::test::assert_browser_locale "da,en-us;q=0.8,de;q=0.5,es;q=0.3" "da_DK"
-
+
# First locale is perfect locale match
lang::test::assert_browser_locale "da_DK,en-us;q=0.8,de;q=0.5,es;q=0.3" "da_DK"
-
+
# Tentative match being discarded
lang::test::assert_browser_locale "da_BLA,foobar,en" "en_US"
-
+
# Tentative match being used
lang::test::assert_browser_locale "da_BLA,foobar" "da_DK"
-
+
# Several tentative matches, all being discarded
lang::test::assert_browser_locale "da_BLA,foobar,da_BLUB,da_DK" "da_DK"
}
}
aa_register_case \
- -cats db \
- strange_oracle_problem {
+ -cats db \
+ strange_oracle_problem {
Strange Oracle problem when selecting by language
-
+
} {
set language "da "
set locale da_DK
- set db_string [db_string select_default_locale {
- select locale
- from ad_locales
+ set db_string [db_string select_default_locale {
+ select locale
+ from ad_locales
where language = :language
} -default "WRONG"]
-
+
aa_false "Does not return 'WRONG'" [string equal $db_string "WRONG"]
}
aa_register_case \
- -procs {
- lang::user::set_timezone
- lang::system::set_timezone
- lang::system::timezone
- } set_get_timezone {
+ -procs {
+ lang::user::set_timezone
+ lang::system::set_timezone
+ lang::system::timezone
+ } set_get_timezone {
Test that setting and getting user timezone works
} {
@@ -862,30 +862,30 @@
set timezones [lc_list_all_timezones]
set n [expr {[llength $timezones]-1}]
-
+
set desired_user_timezone [lindex [lindex $timezones [randomRange $n]] 0]
set desired_system_timezone [lindex [lindex $timezones [randomRange $n]] 0]
-
+
set error_p 0
ad_try {
# User timezone
lang::user::set_timezone $desired_user_timezone
aa_equals "User timezone retrieved is the same as the one set" [lang::user::timezone] $desired_user_timezone
-
+
# Storage
set user_id [ad_conn user_id]
aa_equals "User timezone stored in user_preferences table" \
[db_string user_prefs { select timezone from user_preferences where user_id = :user_id }] \
$desired_user_timezone
-
-
+
+
# System timezone
lang::system::set_timezone $desired_system_timezone
aa_equals "System timezone retrieved is the same as the one set" [lang::system::timezone] $desired_system_timezone
-
+
# Connection timezone
aa_equals "Using user timezone" [lang::conn::timezone] $desired_user_timezone
-
+
ad_conn -set isconnected 0
aa_equals "Fallback to system timezone when no connection" [lang::conn::timezone] $desired_system_timezone
ad_conn -set isconnected 1
@@ -907,10 +907,10 @@
}
aa_register_case \
- -procs {
- lang::user::set_timezone
- lang::system::timezone
- } set_timezone_not_logged_in {
+ -procs {
+ lang::user::set_timezone
+ lang::system::timezone
+ } set_timezone_not_logged_in {
Test that setting and getting user timezone throws an error when user is not logged in
} {
# We cannot test timezones if they are not installed
@@ -924,7 +924,7 @@
set error_p [catch { lang::user::set_timezone [lang::system::timezone] } errmsg]
aa_true "Error when setting user timezone when user not logged in" $error_p
- # Reset the user_id
+ # Reset the user_id
ad_conn -set user_id $user_id
}
}
@@ -937,29 +937,29 @@
aa_register_case \
-procs {
- lang::message::lookup
+ lang::message::lookup
} locale_language_fallback {
- Test that we fall back to 'default locale for language' when requesting a message
+ Test that we fall back to 'default locale for language' when requesting a message
which exists in default locale for language, but not in the current locale
} {
# Assuming we have en_US and en_GB
-
+
set package_key "acs-lang"
set message_key [ad_generate_random_string]
set us_message [ad_generate_random_string]
set gb_message [ad_generate_random_string]
-
+
set error_p 0
ad_try {
lang::message::register "en_US" $package_key $message_key $us_message
-
+
aa_equals "Looking up message in GB returns US message" \
[lang::message::lookup "en_GB" "$package_key.$message_key" "NOT FOUND"] \
$us_message
lang::message::register "en_GB" $package_key $message_key $gb_message
-
+
aa_equals "Looking up message in GB returns GB message" \
[lang::message::lookup "en_GB" "$package_key.$message_key" "NOT FOUND"] \
$gb_message
@@ -977,9 +977,9 @@
aa_register_case \
-procs {
- lang::catalog::import
- lang::message::edit
- lang::message::get
+ lang::catalog::import
+ lang::message::edit
+ lang::message::get
} upgrade {
Test that a package can be upgraded with new
catalog files and that the resulting keys and messages
@@ -1007,10 +1007,10 @@
lang::test::execute_upgrade -locale de_DE
- } -teardown_code {
+ } -teardown_code {
foreach message_key [array names upgrade_expect] {
lang::message::unregister $package_key $message_key
- }
+ }
lang::test::teardown_test_package
}
}
@@ -1063,11 +1063,11 @@
This test calls the checks to ensure a message is correct on every message in the system
} {
aa_run_with_teardown -rollback -test_code {
- db_foreach query "
- select message_key, package_key, locale, message from lang_messages" {
- aa_false "Message $message_key in package $package_key for locale $locale correct" \
- [catch {lang::message::check $locale $package_key $message_key $message}]
- }
+ db_foreach query "
+ select message_key, package_key, locale, message from lang_messages" {
+ aa_false "Message $message_key in package $package_key for locale $locale correct" \
+ [catch {lang::message::check $locale $package_key $message_key $message}]
+ }
}
}
Index: openacs-4/packages/acs-lang/www/admin/set-system-timezone.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-lang/www/admin/set-system-timezone.tcl,v
diff -u -r1.13 -r1.14
--- openacs-4/packages/acs-lang/www/admin/set-system-timezone.tcl 29 Dec 2017 11:13:40 -0000 1.13
+++ openacs-4/packages/acs-lang/www/admin/set-system-timezone.tcl 29 Dec 2017 11:17:34 -0000 1.14
@@ -38,7 +38,7 @@
multirow create timezones label value selected_p
foreach entry [lc_list_all_timezones] {
set tz [lindex $entry 0]
-
+
multirow append timezones $entry $tz [string equal $tz $system_timezone]>
}
@@ -57,7 +57,7 @@
if { [regexp {UTC[^:]+[:][ ]*]*>([^<]+)} $time_and_date_page match utc_from_page] } {
# UTC in format (including some historical ones to help keep a robust regexp:
- # Friday, July 27, 2012 at 19:20:27
+ # Friday, July 27, 2012 at 19:20:27
# Wednesday, 20 November 2002, at 2:49:07 PM
# Wednesday, 6 August 2003, at 12:11:48
# this regexp is a little more flexible and accepting of data types to help with parsing
@@ -102,7 +102,7 @@
} else {
set correct_p 0
}
-
+
set try_offsets [list]
foreach offset [list $recommended_offset [expr {$recommended_offset -24}]] {
if { $offset < 0 } {
@@ -114,7 +114,7 @@
set query "
select tz.tz, tz.gmt_offset
- from timezones tz,
+ from timezones tz,
timezone_rules tzr
where tzr.gmt_offset in ([join $try_offsets ", "])
and tzr.tz_id = tz.tz_id
Index: openacs-4/packages/acs-authentication/tcl/authentication-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-authentication/tcl/authentication-procs.tcl,v
diff -u -r1.91 -r1.92
--- openacs-4/packages/acs-authentication/tcl/authentication-procs.tcl 29 Dec 2017 10:46:39 -0000 1.91
+++ openacs-4/packages/acs-authentication/tcl/authentication-procs.tcl 29 Dec 2017 11:22:07 -0000 1.92
@@ -152,8 +152,7 @@
}
ad_proc -public auth::UseEmailForLoginP {} {
- Do we use email address for login? code wrapped in a catch, so the
- proc will not break regardless of what the parameter value is.
+ Do we use email address for login?
} {
return [parameter::get -boolean -parameter UseEmailForLoginP -package_id [ad_acs_kernel_id] -default 1]
}
@@ -214,7 +213,7 @@
return [array get result]
}
set user_id [party::get_by_email -email $email]
- if { $user_id eq "" || ![acs_user::registered_user_p -user_id $user_id] } {
+ if { $user_id eq "" || ![acs_user::registered_user_p -user_id $user_id] } {
set result(auth_status) "no_account"
set result(auth_message) [_ acs-subsite.Unknown_email]
return [array get result]
@@ -842,7 +841,7 @@
# Help Text
lappend form_element [list help_text $help_text($element)]
-
+
# The form element is finished - add it to the list
lappend form_elements $form_element
} else {
Index: openacs-4/packages/acs-authentication/tcl/authority-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-authentication/tcl/authority-procs.tcl,v
diff -u -r1.31 -r1.32
--- openacs-4/packages/acs-authentication/tcl/authority-procs.tcl 29 Dec 2017 10:46:39 -0000 1.31
+++ openacs-4/packages/acs-authentication/tcl/authority-procs.tcl 29 Dec 2017 11:22:07 -0000 1.32
@@ -22,8 +22,8 @@
{-authority_id ""}
{-array:required}
} {
- Create a new authentication authority.
-
+ Create a new authentication authority.
+
@option authority_id Authority_id, or blank if you want one generated for you.
@param array Name of an array containing the column values. The entries are:
@@ -46,7 +46,7 @@
- forgotten_pwd_url An alternative URL to redirect to when the user has forgotten his/her password.
Defaults to none.
-
+
- change_pwd_url An alternative URL to redirect to when the user wants to change his/her password.
Defaults to none.
@@ -78,10 +78,10 @@
set names [array names row]
- array set column_defaults [get_column_defaults]
+ array set column_defaults [get_column_defaults]
set all_columns [array names column_defaults]
- # Check that the columns provided in the array are all valid
+ # Check that the columns provided in the array are all valid
# Set array entries as local variables
foreach name $names {
if {$name ni $all_columns} {
@@ -134,18 +134,18 @@
set authority_id [db_exec_plsql create_authority {}]
# Set the arguments not taken by the new function with an update statement
- # LARS: Great, we had a nice abstraction going, so you only had to add a new column in
+ # LARS: Great, we had a nice abstraction going, so you only had to add a new column in
# one place, now that abstraction is broken, because you have to add it here as well
- foreach column {
+ foreach column {
user_info_impl_id
get_doc_impl_id
process_doc_impl_id
batch_sync_enabled_p
- help_contact_text_format
+ help_contact_text_format
} {
set edit_columns($column) [set $column]
- }
-
+ }
+
edit -authority_id $authority_id -array edit_columns
}
}
@@ -164,7 +164,7 @@
{-array:required}
} {
Get info about an authority, either by authority_id, user_id, or authority short_name.
-
+
@param authority_id The authority you want to get.
@param array Name of an array into which you want the attributes delivered.
@@ -185,15 +185,15 @@
{-element:required}
} {
Return a specific element of the auth_authority data table.
- Does a complete database query each time. Should not be used multiple times in a row.
+ Does a complete database query each time. Should not be used multiple times in a row.
Use auth::authority::get instead.
@see auth::authority::get
} {
if { [lsearch [get_select_columns] $element] == -1 } {
error "Column '$element' not found in the auth_authority data source."
}
-
+
get -authority_id $authority_id -array row
return $row($element)
}
@@ -205,7 +205,7 @@
Get authority_id by short_name.
@param short_name The short_name of the authority you wish to get information for.
-
+
@return authority_id or the empty string if short_name doesn't exist.
@author Lars Pind (lars@collaboraid.biz)
@@ -218,7 +218,7 @@
{-array:required}
} {
Edit info about a authority. Note, that there's no checking that the columns you name exist.
-
+
@param authority_id The authority you want to get.
@param array Name of an array with column values to update.
@@ -229,9 +229,9 @@
set old_short_name [get_element -authority_id $authority_id -element short_name]
upvar $array row
-
+
set names [array names row]
-
+
# Construct clauses for the update statement
set set_clauses [list]
foreach name $names {
@@ -245,7 +245,7 @@
set columns [get_columns]
- # Check that the columns provided in the array are all valid
+ # Check that the columns provided in the array are all valid
# Set array entries as local variables
foreach name $names {
if {$name ni $columns} {
@@ -256,7 +256,7 @@
}
set $name $row($name)
}
-
+
db_dml update_authority "
update auth_authorities
set [join $set_clauses ", "]
@@ -269,7 +269,7 @@
# check if we need to update the object title
set new_short_name [get_element -authority_id $authority_id -element short_name]
if {$old_short_name ne $new_short_name } {
- db_dml update_object_title {}
+ db_dml update_object_title {}
}
}
@@ -297,7 +297,7 @@
Execute batch synchronization for this authority now.
@param authority_id
- @param snapshot If set, we will delete all authority's users
+ @param snapshot If set, we will delete all authority's users
not touched by the process document proc.
@return job_id
@@ -306,13 +306,13 @@
-authority_id $authority_id]
get -authority_id $authority_id -array authority
-
+
set message {}
# Verify that we have implementations
if { $authority(get_doc_impl_id) eq "" } {
set message "No Get Document implementation"
- } elseif { $authority(process_doc_impl_id) eq "" } {
+ } elseif { $authority(process_doc_impl_id) eq "" } {
set message "No Process Document implementation"
} else {
auth::sync::job::start_get_document -job_id $job_id
@@ -330,7 +330,7 @@
set doc_result(doc_status) failed_to_connect
set doc_result(doc_message) $errorMsg
}
-
+
set snapshot_p [template::util::is_true $doc_result(snapshot_p)]
auth::sync::job::end_get_document \
@@ -346,17 +346,17 @@
-authority_id $authority_id \
-job_id $job_id \
-document $doc_result(document)
-
+
set ack_doc [auth::sync::GetAcknowledgementDocument \
-authority_id $authority_id \
-job_id $job_id \
-document $doc_result(document)]
-
+
set ack_file_name [parameter::get_from_package_key \
-parameter AcknowledgementFileName \
-package_key acs-authentication \
-default {}]
-
+
if { $ack_file_name ne "" } {
# Interpolate
set pairs [list \
@@ -380,7 +380,7 @@
set message $doc_result(doc_message)
}
}
-
+
if { $snapshot_p } {
# If this is a snapshot, we need to delete all the users belonging to this authority
# that weren't included in the snapshot.
@@ -419,7 +419,7 @@
ad_proc -private auth::authority::get_columns {} {
Get a list of the columns in the auth_authorities table.
-
+
@author Lars Pind (lars@collaboraid.biz)
} {
array set column_defaults [get_column_defaults]
@@ -432,7 +432,7 @@
@author Peter Marklund
} {
- set columns {
+ set columns {
authority_id ""
short_name ""
pretty_name ""
@@ -459,10 +459,10 @@
ad_proc -private auth::authority::get_required_columns {} {
Get a list of the required columns in the auth_authorities table.
-
+
@author Lars Pind (lars@collaboraid.biz)
} {
- return {
+ return {
authority_id
short_name
pretty_name
@@ -473,7 +473,7 @@
Get a list of column names for storing service contract implementation ids
of the authority.
- @author Peter Marklund
+ @author Peter Marklund
} {
# DAVEB
set columns {auth_impl_id pwd_impl_id register_impl_id user_info_impl_id get_doc_impl_id process_doc_impl_id}
@@ -485,7 +485,7 @@
ad_proc -private auth::authority::get_select_columns {} {
Get a list of the columns which can be selected from auth_authorities table.
-
+
@author Lars Pind (lars@collaboraid.biz)
} {
set columns [concat [get_columns] auth_impl_name pwd_impl_name register_impl_name user_info_impl_name get_doc_impl_name process_doc_impl_name]
@@ -500,7 +500,7 @@
{-authority_id ""}
} {
Flush the cache for auth::authority::get.
-
+
@see auth::authority::get
} {
if { $authority_id ne "" } {
Index: openacs-4/packages/acs-authentication/tcl/driver-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-authentication/tcl/driver-procs.tcl,v
diff -u -r1.10 -r1.11
--- openacs-4/packages/acs-authentication/tcl/driver-procs.tcl 29 Dec 2017 10:46:39 -0000 1.10
+++ openacs-4/packages/acs-authentication/tcl/driver-procs.tcl 29 Dec 2017 11:22:07 -0000 1.11
@@ -17,7 +17,7 @@
#
#####
-ad_proc -public auth::driver::get_parameters {
+ad_proc -public auth::driver::get_parameters {
{-impl_id:required}
} {
Returns a list of names of parameters for the driver
@@ -88,15 +88,15 @@
@creation-date 2003-08-27
} {
set exists_p [db_string param_exists_p {}]
-
+
if { $exists_p } {
db_dml update_parameter {} -clobs [list $value]
} else {
db_dml insert_parameter {} -clobs [list $value]
}
}
-ad_proc -public auth::driver::GetParameters {
+ad_proc -public auth::driver::GetParameters {
{-impl_id:required}
} {
Returns a list of names of parameters for the driver
Index: openacs-4/packages/acs-authentication/tcl/local-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-authentication/tcl/local-procs.tcl,v
diff -u -r1.41 -r1.42
--- openacs-4/packages/acs-authentication/tcl/local-procs.tcl 29 Dec 2017 10:46:39 -0000 1.41
+++ openacs-4/packages/acs-authentication/tcl/local-procs.tcl 29 Dec 2017 11:22:07 -0000 1.42
@@ -21,27 +21,27 @@
#####
ad_proc -private auth::local::install {} {
- Register local service contract implementations,
+ Register local service contract implementations,
and update the local authority with live information.
} {
db_transaction {
# Register the local service contract implementations
set row(auth_impl_id) [auth::local::authentication::register_impl]
set row(pwd_impl_id) [auth::local::password::register_impl]
set row(register_impl_id) [auth::local::registration::register_impl]
- set row(user_info_impl_id) [auth::local::user_info::register_impl]
+ set row(user_info_impl_id) [auth::local::user_info::register_impl]
# Set the authority pretty-name to be the system name
set row(pretty_name) [ad_system_name]
-
+
auth::authority::edit \
-authority_id [auth::authority::local] \
-array row
}
}
ad_proc -private auth::local::uninstall {} {
- Unregister the local service contract implementation, and update the
+ Unregister the local service contract implementation, and update the
local authority to reflect that.
} {
db_transaction {
@@ -75,7 +75,7 @@
ad_proc -private auth::local::authentication::register_impl {} {
Register the 'local' implementation of the 'auth_authentication' service contract.
-
+
@return impl_id of the newly created implementation.
} {
set spec {
@@ -110,25 +110,25 @@
} {
ns_log Notice "Starting auth::local::authentication::MergeUser"
db_transaction {
- ns_log Notice " Merging user portraits"
+ ns_log Notice " Merging user portraits"
- ns_log notice " Merging username, email and basic info in general"
+ ns_log notice " Merging username, email and basic info in general"
- set new_username "merged_$from_user_id"
- append new_username "_$to_user_id"
-
- # Shall we keep the domain for email?
- # Actually, the username 'merged_xxx_yyy'
- # won't be an email, so we will keep it without
- # domain
- set new_email $new_username
-
- set rel_id [db_string getrelid {}]
- membership_rel::change_state -rel_id $rel_id -state "merged"
-
- acs_user::update -user_id $from_user_id -username "$new_username" -screen_name "$new_username"
- party::update -party_id $from_user_id -email "$new_email"
-
+ set new_username "merged_$from_user_id"
+ append new_username "_$to_user_id"
+
+ # Shall we keep the domain for email?
+ # Actually, the username 'merged_xxx_yyy'
+ # won't be an email, so we will keep it without
+ # domain
+ set new_email $new_username
+
+ set rel_id [db_string getrelid {}]
+ membership_rel::change_state -rel_id $rel_id -state "merged"
+
+ acs_user::update -user_id $from_user_id -username "$new_username" -screen_name "$new_username"
+ party::update -party_id $from_user_id -email "$new_email"
+
}
ns_log notice "Finishing auth::local::authentication::MergeUser"
}
@@ -140,13 +140,13 @@
{parameters {}}
{authority_id {}}
} {
- Implements the Authenticate operation of the auth_authentication
+ Implements the Authenticate operation of the auth_authentication
service contract for the local account implementation.
} {
array set auth_info [list]
if {$authority_id eq ""} {
- set authority_id [auth::authority::local]
+ set authority_id [auth::authority::local]
}
set user_id [acs_user::get_by_username -authority_id $authority_id -username $username]
@@ -163,15 +163,15 @@
return [array get auth_info]
}
- # We set 'external' account status to 'ok', because the
+ # We set 'external' account status to 'ok', because the
# local account status will be checked anyways by the framework
set auth_info(account_status) ok
return [array get auth_info]
}
ad_proc -private auth::local::authentication::GetParameters {} {
- Implements the GetParameters operation of the auth_authentication
+ Implements the GetParameters operation of the auth_authentication
service contract for the local account implementation.
} {
# No parameters
@@ -190,7 +190,7 @@
ad_proc -private auth::local::password::register_impl {} {
Register the 'local' implementation of the 'auth_password' service contract.
-
+
@return impl_id of the newly created implementation.
} {
set spec {
@@ -221,7 +221,7 @@
ad_proc -private auth::local::password::CanChangePassword {
{parameters ""}
} {
- Implements the CanChangePassword operation of the auth_password
+ Implements the CanChangePassword operation of the auth_password
service contract for the local account implementation.
} {
# Yeah, we can change your password
@@ -231,7 +231,7 @@
ad_proc -private auth::local::password::CanRetrievePassword {
{parameters ""}
} {
- Implements the CanRetrievePassword operation of the auth_password
+ Implements the CanRetrievePassword operation of the auth_password
service contract for the local account implementation.
} {
# passwords are stored hashed, so we send the hash and let the user choose a new password
@@ -241,7 +241,7 @@
ad_proc -private auth::local::password::CanResetPassword {
{parameters ""}
} {
- Implements the CanResetPassword operation of the auth_password
+ Implements the CanResetPassword operation of the auth_password
service contract for the local account implementation.
} {
# Yeah, we can reset for you.
@@ -255,12 +255,12 @@
{parameters {}}
{authority_id {}}
} {
- Implements the ChangePassword operation of the auth_password
+ Implements the ChangePassword operation of the auth_password
service contract for the local account implementation.
} {
- array set result {
+ array set result {
password_status {}
- password_message {}
+ password_message {}
}
set user_id [acs_user::get_by_username -authority_id $authority_id -username $username]
@@ -270,10 +270,10 @@
}
if { $old_password ne "" } {
- if { ![ad_check_password $user_id $old_password] } {
- set result(password_status) "old_password_bad"
- return [array get result]
- }
+ if { ![ad_check_password $user_id $old_password] } {
+ set result(password_status) "old_password_bad"
+ return [array get result]
+ }
}
ad_try {
@@ -287,43 +287,43 @@
set result(password_status) "ok"
if { [parameter::get -parameter EmailAccountOwnerOnPasswordChangeP -package_id [ad_acs_kernel_id] -default 1] } {
- ad_try {
- acs_user::get -username $username -authority_id $authority_id -array user
-
- set system_name [ad_system_name]
- set pvt_home_name [ad_pvt_home_name]
- set password_update_link_text [_ acs-subsite.Change_my_Password]
-
- if { [auth::UseEmailForLoginP] } {
- set account_id_label [_ acs-subsite.Email]
- set account_id $user(email)
- } else {
- set account_id_label [_ acs-subsite.Username]
- set account_id $user(username)
- }
-
- set subject [_ acs-subsite.Password_changed_subject]
- set body [_ acs-subsite.Password_changed_body]
-
- acs_mail_lite::send \
+ ad_try {
+ acs_user::get -username $username -authority_id $authority_id -array user
+
+ set system_name [ad_system_name]
+ set pvt_home_name [ad_pvt_home_name]
+ set password_update_link_text [_ acs-subsite.Change_my_Password]
+
+ if { [auth::UseEmailForLoginP] } {
+ set account_id_label [_ acs-subsite.Email]
+ set account_id $user(email)
+ } else {
+ set account_id_label [_ acs-subsite.Username]
+ set account_id $user(username)
+ }
+
+ set subject [_ acs-subsite.Password_changed_subject]
+ set body [_ acs-subsite.Password_changed_body]
+
+ acs_mail_lite::send \
-send_immediately \
-to_addr $user(email) \
-from_addr [ad_outgoing_sender] \
-subject $subject \
-body $body
- } on error {errorMsg} {
+ } on error {errorMsg} {
ad_log Error "Error sending out password changed notification to account owner with user_id $user(user_id), email $user(email): $errorMsg"
- }
+ }
}
-
+
return [array get result]
}
ad_proc -private auth::local::password::RetrievePassword {
username
parameters
} {
- Implements the RetrievePassword operation of the auth_password
+ Implements the RetrievePassword operation of the auth_password
service contract for the local account implementation.
} {
set result(password_status) "ok"
@@ -352,12 +352,12 @@
{authority_id {}}
{new_password {}}
} {
- Implements the ResetPassword operation of the auth_password
+ Implements the ResetPassword operation of the auth_password
service contract for the local account implementation.
} {
- array set result {
+ array set result {
password_status ok
- password_message {}
+ password_message {}
}
set user_id [acs_user::get_by_username -authority_id $authority_id -username $username]
@@ -368,9 +368,9 @@
# Reset the password
if { $new_password ne "" } {
- set password $new_password
+ set password $new_password
} else {
- set password [ad_generate_random_string]
+ set password [ad_generate_random_string]
}
ad_change_password $user_id $password
@@ -403,7 +403,7 @@
ad_proc -private auth::local::registration::register_impl {} {
Register the 'local' implementation of the 'auth_registration' service contract.
-
+
@return impl_id of the newly created implementation.
} {
set spec {
@@ -434,7 +434,7 @@
} {
set result(required) {}
if { ![auth::UseEmailForLoginP] } {
- set result(required) username
+ set result(required) username
}
lappend result(required) email first_names last_name
@@ -444,9 +444,9 @@
lappend result(optional) password
}
- if { [parameter::get -package_id [ad_acs_kernel_id] -parameter RequireQuestionForPasswordResetP -default 0] &&
+ if { [parameter::get -package_id [ad_acs_kernel_id] -parameter RequireQuestionForPasswordResetP -default 0] &&
[parameter::get -package_id [ad_acs_kernel_id] -parameter UseCustomQuestionForPasswordReset -default 0] } {
- lappend result(required) secret_question secret_answer
+ lappend result(required) secret_question secret_answer
}
return [array get result]
@@ -505,28 +505,28 @@
-parameter EmailRegistrationConfirmationToUserP \
-package_id [ad_conn subsite_id] -default 1]] != 0
} {
- if { $generated_pwd_p
+ if { $generated_pwd_p
|| [parameter::get \
-parameter RegistrationProvidesRandomPasswordP \
-package_id [ad_conn subsite_id] -default 0]
|| $email_reg_confirm_p
} {
- ad_try {
- auth::password::email_password \
- -username $username \
- -authority_id $authority_id \
- -password $password \
- -from [parameter::get \
+ ad_try {
+ auth::password::email_password \
+ -username $username \
+ -authority_id $authority_id \
+ -password $password \
+ -from [parameter::get \
-parameter NewRegistrationEmailAddress \
-package_id [ad_conn subsite_id] \
-default [ad_system_owner]] \
- -subject_msg_key "acs-subsite.email_subject_Registration_password" \
- -body_msg_key "acs-subsite.email_body_Registration_password"
- } on error {errorMsg} {
- # We don't fail hard here, just log an error
- ad_log Error "Error sending registration confirmation to $email: $errorMsg"
- }
- }
+ -subject_msg_key "acs-subsite.email_subject_Registration_password" \
+ -body_msg_key "acs-subsite.email_body_Registration_password"
+ } on error {errorMsg} {
+ # We don't fail hard here, just log an error
+ ad_log Error "Error sending registration confirmation to $email: $errorMsg"
+ }
+ }
}
# LARS TODO: Move this out of the local driver and into the auth framework
@@ -575,8 +575,8 @@
#
ad_proc -private auth::local::user_info::register_impl {} {
- Register the 'local' implementation of the 'auth_user_info' service contract.
-
+ Register the 'local' implementation of the 'auth_user_info' service contract.
+
@return impl_id of the newly created implementation.
} {
set spec {
@@ -632,7 +632,7 @@
set results [list]
db_foreach user_search {} {
- lappend results $user_id
+ lappend results $user_id
}
return $results
Index: openacs-4/packages/acs-authentication/tcl/password-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-authentication/tcl/password-procs.tcl,v
diff -u -r1.21 -r1.22
--- openacs-4/packages/acs-authentication/tcl/password-procs.tcl 29 Dec 2017 10:46:39 -0000 1.21
+++ openacs-4/packages/acs-authentication/tcl/password-procs.tcl 29 Dec 2017 11:22:07 -0000 1.22
@@ -39,11 +39,11 @@
# Interpolate any username variable in URL
regsub -all "{username}" $change_pwd_url $username change_pwd_url
-
+
# Default to the OpenACS change password URL
if { $change_pwd_url eq "" } {
set change_pwd_url [export_vars -base "[subsite::get_element -element url]user/password-update" { user_id }]
- }
+ }
return $change_pwd_url
}
@@ -52,16 +52,16 @@
{-user_id:required}
} {
Returns whether we can change the password for the given user.
- This depends on the user's authority and the configuration of that authority.
-
+ This depends on the user's authority and the configuration of that authority.
+
@param user_id The ID of the user whose password you want to change.
@return 1 if the user can change password, 0 otherwise.
} {
set authority_id [acs_user::get_element -user_id $user_id -element authority_id]
set result_p 0
- ad_try {
+ ad_try {
set result_p [auth::password::CanChangePassword -authority_id $authority_id]
} on error {errorMsg} {
ad_log Error "Error invoking CanChangePassword operation for authority_id $authority_id"
@@ -98,7 +98,7 @@
-authority_id $user(authority_id) \
-username $user(username) \
-new_password $new_password \
- -old_password $old_password ]
+ -old_password $old_password ]
# We do this so that if there aren't even a password_status in the array, that gets caught below
set dummy $result(password_status)
@@ -107,7 +107,7 @@
set result(password_message) $errorMsg
ad_log Error "Error invoking password management driver for authority_id = $user(authority_id): $errorMsg"
}
-
+
# Check the result code and provide canned responses
switch $result(password_status) {
ok {
@@ -116,12 +116,12 @@
sec_change_user_auth_token $user_id
- # Refresh the current user's cookies, so he doesn't get logged out,
+ # Refresh the current user's cookies, so he doesn't get logged out,
# if this user was logged in before changing password
if { [ad_conn isconnected] && $user_id == $connection_user_id } {
auth::issue_login -account_status [ad_conn account_status] -user_id $user_id
}
- }
+ }
no_account - not_supported - old_password_bad - new_password_bad - change_error - failed_to_connect {
if { ![info exists result(password_message)] || $result(password_message) eq "" } {
array set default_message {
@@ -149,9 +149,9 @@
{-authority_id ""}
{-username ""}
{-email ""}
-} {
- Handles forgotten passwords. Attempts to retrieve a password; if not possibe,
- attempts to reset a password. If it succeeds, it emails the user. For all
+} {
+ Handles forgotten passwords. Attempts to retrieve a password; if not possibe,
+ attempts to reset a password. If it succeeds, it emails the user. For all
outcomes, it returns a message to be displayed.
@param authority_id The ID of the authority that the user is trying to log into.
@@ -223,14 +223,14 @@
{-username ""}
{-email ""}
{-remote_only:boolean}
-} {
- Returns the URL to redirect to for forgotten passwords.
-
+} {
+ Returns the URL to redirect to for forgotten passwords.
+
@param authority_id The ID of the authority that the user is trying to log into.
@param username The username that the user's trying to log in with.
@param remote_only If provided, only return any remote URL (not on this server).
- @return A URL that can be linked to when the user has forgotten his/her password,
+ @return A URL that can be linked to when the user has forgotten his/her password,
or the empty string if none can be found.
} {
if { $username ne "" } {
@@ -255,8 +255,8 @@
if { $username ne "" } {
# We have the username or email
-
+
set forgotten_pwd_url [auth::authority::get_element -authority_id $authority_id -element forgotten_pwd_url]
if { $forgotten_pwd_url ne "" } {
@@ -272,21 +272,21 @@
set forgotten_pwd_url "[subsite::get_element -element url]register/recover-password"
}
}
-
+
return $forgotten_pwd_url
}
ad_proc -public auth::password::can_retrieve_p {
{-authority_id:required}
} {
- Returns whether the given authority can retrive forgotten passwords.
-
+ Returns whether the given authority can retrive forgotten passwords.
+
@param authority_id The ID of the authority that the user is trying to log into.
@return 1 if the authority allows retrieving passwords, 0 otherwise.
} {
set result_p 0
- ad_try {
+ ad_try {
set result_p [auth::password::CanRetrievePassword \
-authority_id $authority_id]
} on error {errorMsg} {
@@ -315,7 +315,7 @@
- password_message: A human-readable message to be
relayed to the user. May be empty if password_status is ok. May
- include HTML.
+ include HTML.
- password: The retrieved password.
@@ -325,15 +325,15 @@
array set result [auth::password::RetrievePassword \
-authority_id $authority_id \
-username $username]
-
+
# We do this so that if there aren't even a password_status in the array, that gets caught below
set dummy $result(password_status)
} on error {errorMsg} {
set result(password_status) failed_to_connect
set result(password_message) "Error invoking the password management driver."
ad_log Error "Error invoking password management driver for authority_id = $authority_id: $errorMsg"
}
-
+
# Check the result code and provide canned responses
switch $result(password_status) {
ok {
@@ -345,18 +345,18 @@
-username $username \
-password $result(password) \
-subject_msg_key "acs-subsite.email_subject_Forgotten_password" \
- -body_msg_key "acs-subsite.email_body_Forgotten_password"
+ -body_msg_key "acs-subsite.email_body_Forgotten_password"
} on error {errorMsg} {
# We could not inform the user of his email - we failed
set result(password_status) "failed_to_connect"
set result(password_message) [_ acs-subsite.Error_sending_mail]
ad_log Error "We had an error sending out email with new password to username $username, authority $authority_id: $errorMsg"
}
- }
+ }
if { ![info exists result(password_message)] || $result(password_message) eq "" } {
set result(password_message) [_ acs-subsite.Check_Your_Inbox]
}
- }
+ }
no_account - not_supported - retrieve_error - failed_to_connect {
if { ![info exists result(password_message)] || $result(password_message) eq "" } {
array set default_message {
@@ -380,14 +380,14 @@
ad_proc -public auth::password::can_reset_p {
{-authority_id:required}
} {
- Returns whether the given authority can reset forgotten passwords.
-
+ Returns whether the given authority can reset forgotten passwords.
+
@param authority_id The ID of the authority that the user is trying to log into.
@return 1 if the authority allows resetting passwords, 0 otherwise.
} {
set result_p 0
- ad_try {
+ ad_try {
set result_p [auth::password::CanResetPassword \
-authority_id $authority_id]
} on error {errorMsg} {
@@ -429,20 +429,20 @@
user of his/her new password.