Benjamin Brink
OpenACS community
Spreadsheet package for collaboratively building and managing spreadsheets.
- 2014-10-23
+ 2017-01-01
Spreadsheet package provides users with some spreadsheet-like functionality, such as ability to perform basic queries on package tables for generating customized reports. Smallest spreadsheet can be 1 by 1.
- GPLv3
- https://github.com/tekbasse/spreadsheet/blob/master/README.md
- 0
- spreadsheet
+ GNU gpl v2
+ http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+ 1
+ Spreadsheet
-
+
Index: openacs-4/packages/spreadsheet/tcl/spreadsheet-util-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/spreadsheet/tcl/spreadsheet-util-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/spreadsheet/tcl/spreadsheet-util-procs.tcl 2 Jan 2017 10:36:06 -0000 1.1
@@ -0,0 +1,137 @@
+ad_library {
+
+ misc util procedures..
+ @creation-date 2 June 2016
+ @Copyright (c) 2016 Benjamin Brink
+ @license GNU General Public License 2, see project home
+ @project home: http://github.com/tekbasse/spreadsheet
+ @address: po box 20, Marylhurst, OR 97036-0020 usa
+ @email: tekbasse@yahoo.com
+
+ see: http://wiki.tcl.tk/39012 for interval_*ymdhms procs discussion
+}
+
+ad_proc -public qss_lists_to_array {
+ array_name
+ values_lists
+ ref_key
+ {key_list ""}
+} {
+ Converts a list of lists into an array in the calling environment: array_name(ref_key,N) where N are elements of key_list.
+ Returns 1 if successful, otherwise returns 0.
+ Assumes lists in values_lists (a list of lists) are of consistent length as key_list, and that the first list is not a header.
+ If key_list is empty, first list of lists will be used as key_list. If first row has duplicates, a sequence of numbers starting with 0 will be used.
+ A list of all references of ref_key are returned in array_name(ref_key_list).
+} {
+ upvar 1 $array_name an_arr
+ set success_p 0
+ if { $key_list eq "" } {
+ set k_list [lindex $values_list 0]
+ # any duplicate names?
+ if { [llength $k_list] > [llength [lsort -unique $k_list]] } {
+ set i 0
+ set key_list [list ]
+ foreach k $k_list {
+ lappend key_list $i
+ incr i
+ }
+ } else {
+ set key_list $k_list
+ set values_lists [lrange $values_list 1 end]
+ }
+ }
+ set ref_key -1
+ if { $ref_key ne "" } {
+ set key_idx [lsearch -exact $key_list $ref_key]
+ }
+ set ref_key_list [list ]
+ set j 0
+ foreach row_list $values_lists {
+ set i 0
+ if { $key_idx > -1 } {
+ set row_id [lindex $row_list $key_idx]
+ } else {
+ set row_id $j
+ }
+ foreach key $key_list {
+ set x "${row_id},${key}"
+ set an_arr(${x}) [lindex $row_list $i]
+ incr i
+ }
+ lappend ref_key_list $row_id
+ incr j
+ }
+ set an_arr(ref_key_list) $ref_key_list
+ return $success_p
+}
+
+
+ad_proc -public qss_lists_to_vars {
+ values_lists
+ ref_key
+ {key_list ""}
+} {
+ Converts a list of lists into variables in the calling environment: Variable {R}_{C} where R is the the value in row R at position of ref_key, and C is the key of the same position. Each variable returns one element of the list of lists.
+
+ For example, consider a list of lists:
+ { {Aye Bee Main Ville 12345} {Dan Easy Side Troy 23456} {Fred Ghee Ton 34567}}
+
+ key_list is {first_name last street city postcode}
+
+ ref_key is "Last"
+
+ Variables with cooresponding values for first row are: Bee_first_name Bee_last Bee_street Bee_city Bee_postcode
+
+ Returns the list of variable names, or blank if unsuccessful.
+
+ Assumes lists in values_lists (a list of lists) are of consistent length as key_list, and that the first list is not a header.
+
+ If key_list is empty, first list of lists will be used as key_list. If there are duplicates in key_list, then a sequence of numbers are used instead.
+
+ If ref_key is empty, uses a sequence of integers starting with 0. For example, 0_street, 1_street, 2_street, 0_city, 1_city, ..
+
+ Worst case, list of variables returned are: 0_0 0_1 0_2 0_3 1_0 1_1 1_2 1_3 2_0..
+
+ A list of all variaables are returned as a list.
+} {
+ set success_p 0
+ set variables_list [list ]
+ if { $key_list eq "" } {
+ set k_list [lindex $values_list 0]
+ # any duplicate names?
+ if { [llength $k_list] > [llength [lsort -unique $k_list]] } {
+ set i 0
+ set key_list [list ]
+ foreach k $k_list {
+ lappend key_list $i
+ incr i
+ }
+ } else {
+ set key_list $k_list
+ set values_lists [lrange $values_list 1 end]
+ }
+ }
+ set ref_key -1
+ if { $ref_key ne "" } {
+ set key_idx [lsearch -exact $key_list $ref_key]
+ }
+ set ref_key_list [list ]
+ set j 0
+ foreach row_list $values_lists {
+ set i 0
+ if { $key_idx > -1 } {
+ set row_id [lindex $row_list $key_idx]
+ } else {
+ set row_id $j
+ }
+ foreach key $key_list {
+ set var_name ${row_id}_${key}
+ set $var_name [lindex $row_list $i]
+ upvar 1 $var_name $var_name
+ lappend variables_list $var_name
+ incr i
+ }
+ incr j
+ }
+ return $variables_list
+}
Index: openacs-4/packages/spreadsheet/tcl/tips-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/spreadsheet/tcl/tips-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/spreadsheet/tcl/tips-procs.tcl 2 Jan 2017 10:36:06 -0000 1.1
@@ -0,0 +1,1742 @@
+ad_library {
+
+ API for the qss_TIPS api
+ @creation-date 12 Oct 2016
+ @cs-id $Id:
+}
+
+ad_proc -private qss_tips_user_id_set {
+} {
+ Sets user_id in calling environment,
+ @return user_id, or 0 if not a logged in user, or -1 if not called via connected session.
+} {
+ upvar 1 user_id user_id
+ if { [ns_conn isconnected] } {
+ set user_id [ad_conn user_id]
+ } else {
+ set user_id -1
+ }
+ return 1
+}
+
+ad_proc -public qss_tips_field_id_name_list {
+ table_id
+} {
+ Returns a name value list of field names and field ids.
+} {
+ upvar 1 instance_id instance_id
+ set id_name_list [list ]
+ if {[qf_is_natural_number $table_id ]} {
+ set db_sql {
+ select id,name from qss_tips_field_defs
+ where instance_id=:instance_id
+ and table_id=:table_id
+ and trashed_p!='1'}
+ set fields_lists [db_list_of_lists qss_tips_field_defs_id_name_r $db_sql]
+ foreach row $fields_lsits {
+ foreach {id name} {
+ lappend id_name_list $id $name
+ }
+ }
+ }
+ return $id_name_list
+}
+
+ad_proc -public qss_tips_field_label_name_list {
+ table_id
+} {
+ Returns a name value list of field names and field labels.
+} {
+ upvar 1 instance_id instance_id
+ set label_name_list [list ]
+ if {[qf_is_natural_number $table_id ]} {
+ set db_sql {select label,name from qss_tips_field_defs
+ where instance_id=:instance_id
+ and table_id=:table_id
+ and trashed_p!='1'}
+ set fields_lists [db_list_of_lists qss_tips_field_defs_label_name_r $db_sql]
+ foreach row $fields_lsits {
+ foreach {label name} {
+ lappend label_name_list $label $name
+ }
+ }
+ }
+ return label_name_list
+}
+
+
+ad_proc -private qss_tips_field_defs_maps_set {
+ table_id
+ {field_type_of_label_array_name ""}
+ {field_id_of_label_array_name ""}
+ {field_type_of_id_array_name ""}
+ {field_label_of_id_array_name ""}
+ {field_ids_list_name ""}
+ {field_labels_list_name ""}
+ {filter_by_label_list ""}
+} {
+ Returns count of fields returned.
+ If filter_by_label_list is nonempty, scopes to return info on only field definitions in filter_by_label_list.
+
+ If field_type_of_label_array_name is nonempty, returns an array in calling environment
+ of that name in the form field_type_of(label) for example.
+
+ If field_id_of_label_array_name is nonempty, returns an array in calling environment
+ of that name in the form field_id_of(label) for example.
+
+ If field_type_of_id_array_name is nonempty, returns an array in calling environment
+ of that name in the form field_type_of(id) for example.
+
+ If field_label_of_id_array_name is nonempty, returns an array in calling environment
+ of that name in the form field_label_of(id) for example.
+
+ If field_labels_list_name is nonempty, returns a list of field labels in calling environment.
+
+ If field_ids_list_name is nonempty, returns a list of field ids in calling environment.
+} {
+ upvar 1 instance_id instance_id
+ set fields_lists [qss_tips_field_def_read $table_id $filter_by_label_list]
+ ns_log Notice "qss_tips_field_defs_maps_set.96: fields_lists '${fields_lists}'"
+ if { $field_ids_list_name ne "" } {
+ upvar 1 $field_ids_list_name field_ids_list
+ }
+ if { $field_labels_list_name ne "" } {
+ upvar 1 $field_labels_list_name field_labels_list
+ }
+ set field_labels_list [list ]
+ set field_ids_list [list ]
+ set set_field_type_label_arr_p 0
+ if { [regexp -all -nocase -- {^[a-z0-9\_]+$} $field_type_of_label_array_name] } {
+ upvar 1 $field_type_of_label_array_name field_type_label_arr
+ set set_field_type_label_arr_p 1
+ }
+ set set_field_id_label_arr_p 0
+ if { [regexp -all -nocase -- {^[a-z0-9\_]+$} $field_id_of_label_array_name ] } {
+ upvar 1 $field_id_of_label_array_name field_id_label_arr
+ set set_field_id_label_arr_p 1
+ }
+ set set_field_type_id_arr_p 0
+ if { [regexp -all -nocase -- {^[a-z0-9\_]+$} $field_type_of_id_array_name ] } {
+ upvar 1 $field_type_of_id_array_name field_type_id_arr
+ set set_field_type_id_arr_p 1
+ }
+ set set_field_label_id_arr_p 0
+ if { [regexp -all -nocase -- {^[a-z0-9\_]+$} $field_label_of_id_array_name ] } {
+ upvar 1 $field_label_of_id_array_name field_label_id_arr
+ set set_field_label_id_arr_p 1
+ }
+ if { [llength $fields_lists ] > 0 } {
+ foreach field_list $fields_lists {
+ foreach {field_id label name def_val tdt_type field_type} $field_list {
+ lappend field_labels_list $label
+ lappend field_ids_list $field_id
+ lappend field_label_type_list $label $field_type
+ lappend field_label_id_list $label $field_id
+ lappend field_id_label_list $field_id $label
+ lappend field_id_type_list $field_id $field_type
+ }
+ }
+ if { $set_field_type_label_arr_p } {
+ array set field_type_label_arr $field_label_type_list
+ ns_log Notice "qss_tips_field_defs_maps_set.137: field_label_type_list '${field_label_type_list}'"
+ }
+ if { $set_field_id_label_arr_p } {
+ array set field_id_label_arr $field_label_id_list
+ ns_log Notice "qss_tips_field_defs_maps_set.140: field_label_id_list '${field_label_id_list}'"
+ }
+ if { $set_field_type_id_arr_p } {
+ array set field_type_id_arr $field_id_type_list
+ ns_log Notice "qss_tips_field_defs_maps_set.145: field_id_type_list '${field_id_type_list}'"
+ }
+ if { $set_field_label_id_arr_p } {
+ array set field_label_id_arr $field_id_label_list
+ ns_log Notice "qss_tips_field_defs_maps_set.140: field_id_label_list '${field_id_label_list}'"
+ }
+ }
+ set count [llength $field_labels_list]
+ return $count
+}
+
+ad_proc -public qss_tips_table_id_of_label {
+ table_label
+} {
+ Returns table_id of table_label, or empty string if not found.
+} {
+ # cannot check for trashed tables, because that could give multiple results.
+ upvar 1 instance_id instance_id
+ set table_id ""
+ set db_sql {
+ select id as table_id from qss_tips_table_defs
+ where label=:table_label
+ and instance_id=:instance_id
+ and trashed_p!='1'}
+ db_0or1row qss_tips_table_defs_r_name_untrashed $db_sql
+ return $table_id
+}
+
+ad_proc -private qss_tips_table_id_exists_q {
+ table_id
+ {trashed_p "0"}
+} {
+ Returns 1 if table_id exists.
+
+ Defaults to only check untrashed tables (trashed_p is 0).
+
+ Set trashed_p to 1 to check all cases.
+} {
+ upvar 1 instance_id instance_id
+ if { ![qf_is_true $trashed_p ] } {
+ set exists_p [db_0or1row qss_tips_trashed_table_id_exists {
+ select id from qss_tips_table_defs
+ where id=:table_id
+ and instance_id=:instance_id limit 1
+ } ]
+ } else {
+ set exists_p [db_0or1row qss_tips_untrashed_table_id_exists {
+ select id from qss_tips_table_defs
+ where id=:table_id
+ and instance_id=:instance_id
+ and trashed_p!='1' limit 1
+ } ]
+ }
+ return $exists_p
+}
+
+
+ad_proc -private qss_tips_field_def_id_exists_q {
+ field_id
+ table_id
+ {trashed_p "0"}
+} {
+ Returns 1 if field_id exists for table_id.
+
+ Defaults to only check untrashed fields (trashed_p is 0).
+
+ Set trashed_p to 1 to check all cases.
+} {
+ upvar 1 instance_id instance_id
+ if { ![qf_is_true $trashed_p ] } {
+ set exists_p [db_0or1row qss_tips_trashed_field_id_exists {
+ select id from qss_tips_field_defs
+ where id=:field_id
+ and table_id=:table_id
+ and instance_id=:instance_id limit 1
+ } ]
+ } else {
+ set exists_p [db_0or1row qss_tips_untrashed_field_id_exists {
+ select id from qss_tips_field_defs
+ where id=:field_id
+ and table_id=:table_id
+ and instance_id=:instance_id
+ and trashed_p!='1' limit 1
+ } ]
+ }
+ return $exists_p
+}
+
+
+ad_proc -private qss_tips_row_id_exists_q {
+ row_id
+ table_id
+ {trashed_p "0"}
+} {
+ Returns 1 if row_id of table_id exists.
+ Defaults to only check untrashed tables (trashed_p is 0).
+ Set trashed_p to 1 to check all cases.
+} {
+ upvar 1 instance_id instance_id
+ if { [qf_is_true $trashed_p ] } {
+ set exists_p [db_0or1row qss_tips_trashed_row_id_exists {
+ select row_id from qss_tips_field_values
+ where row_id=:row_id
+ and table_id=:table_id
+ and instance_id=:instance_id limit 1} ]
+ } else {
+ set exists_p [db_0or1row qss_tips_untrashed_row_id_exists {
+ select row_id from qss_tips_field_values
+ where row_id=:row_id
+ and table_id=:table_id
+ and instance_id=:instance_id
+ and trashed_p!='1' limit 1 } ]
+ }
+ return $exists_p
+}
+
+ad_proc -public qss_tips_table_def_read {
+ table_label
+} {
+ Returns list of table_id, label, name, flags, trashed_p or empty list if not found.
+} {
+ upvar 1 instance_id instance_id
+ set table_list [list ]
+ set db_sql {select id,label,name,flags,trashed_p from qss_tips_table_defs
+ where label=:table_label
+ and instance_id=:instance_id
+ and trashed_p!='1'}
+ set exists_p [db_0or1row qss_tips_table_defs_r1_untrashed $db_sql]
+ if { $exists_p } {
+ set table_list [list $id $label $name $flags $trashed_p]
+ }
+ return $table_list
+}
+
+ad_proc -public qss_tips_table_def_read_by_id {
+ table_id
+} {
+ Returns list of table_id, label, name, flags, trashed_p or empty list if not found.
+} {
+ upvar 1 instance_id instance_id
+ set table_list [list ]
+ set db_sql {select id,label,name,flags,trashed_p from qss_tips_table_defs
+ where id=:table_id
+ and instance_id=:instance_id
+ and trashed_p!='1'}
+ set exists_p [db_0or1row qss_tips_table_defs_r1_untrashed $db_sql]
+ if { $exists_p } {
+ lappend table_list $id $label $name $flags $trashed_p
+ }
+ return $table_list
+}
+
+
+ad_proc -public qss_tips_table_def_create {
+ label
+ name
+ {flags ""}
+} {
+ Defines a tips table. Label is a short reference (up to 40 chars) with no spaces.
+ Name is usually a title for display and has spaces (40 char max).
+ If label exists, will rename label to "-integer".
+ @return id if successful, otherwise returns empty string.
+} {
+ upvar 1 instance_id instance_id
+
+ # fields may not be defined at the same time the table is
+ # new fields may be applied to existing tables,
+ # resulting in fields with no (empty) values.
+ # New columns start with empty values.
+ # This should also help when importing data. A new column could be temporarily added,
+ # then removed after data has been integrated into other columns for example.
+ #
+ # sql doesn't have to create an empty data.
+ # When reading, assume column is empty, unless data exists -- consistent with simple_tables
+ set id ""
+ qss_tips_user_id_set
+ if { [hf_are_printable_characters_q $label] && [hf_are_visible_characters_q $name] } {
+ set existing_id [qss_tips_table_id_of_label $label]
+ set label_len [string length $label]
+ set name_len [string length $name]
+ set i 1
+ if { $label_len > 39 || $name_len > 39 } {
+ incr i
+ set chars_max [expr { 38 - [string length $i] } ]
+ if { $label_len > 39 } {
+ set label [qf_abbreviate $label $chars_max "" "_"]
+ append label "-" $i
+ }
+ if { $name_len > 39 } {
+ set name [qf_abbreviate $name $chars_max ".." " "]
+ }
+ }
+ set label_orig $label
+ while { $existing_id ne "" && $i < 1000 } {
+ incr i
+ set chars_max [expr { 38 - [string length $i] } ]
+ set label [string range $label_orig 0 $chars_max]
+ append label "-" $i
+ set existing_id [qss_tips_table_id_of_label $label]
+ }
+ if { $existing_id eq "" } {
+ set id [db_nextval qss_tips_id_seq]
+ set trashed_p "0"
+ db_dml qss_tips_table_cre {
+ insert into qss_tips_table_defs
+ (instance_id,id,label,name,flags,user_id,created,trashed_p)
+ values (:instance_id,:id,:label,:name,:flags,:user_id,now(),:trashed_p)
+ }
+ } else {
+ ns_log Notice "qss_tips_table_def_create.273: table label '${label}' already exists."
+ }
+ } else {
+ ns_log Notice "qss_tips_table_def_create.276: table label or name includes characters not allowed."
+ }
+ return $id
+}
+
+
+ad_proc -public qss_tips_table_def_update {
+ table_id
+ args
+} {
+ Updates a table definition for table_id.
+
+ args can be passed as name value list or parameters.
+
+ Accepted names are: label, name, and flags.
+
+ @return 1 if successful, otherwise 0.
+} {
+ upvar 1 instance_id instance_id
+ set exists_p [db_0or1row qss_tips_table_def_ur {
+ select label,name,flags from qss_tips_table_defs
+ where instance_id=:instance_id
+ and id=:table_id
+ and trashed_p!='1'}]
+ if { $exists_p } {
+ # Allow args to be passed as a list or separate parameters
+ set args_list [list ]
+ set arg1 [lindex $args 0]
+ if { [llength $arg1] > 1 } {
+ set args_list $arg1
+ }
+ set args_list [concat $args_list $args]
+
+ set field_list [list label name flags]
+ set field_len_limit_list [list label name]
+ set changed_p 0
+ foreach {arg val} $args_list {
+ if { $arg in $field_list } {
+ set changed_p 1
+ set $arg $val
+ if { $arg in $field_len_limit_list } {
+ if { [string length $val] > 39 } {
+ set i 2
+ set chars_max [expr { 38 - [string length $i] } ]
+ if { $arg eq "name" } {
+ set name [qf_abbreviate $val $chars_max ".." " "]
+ } elseif { $arg eq "label" } {
+ set label_orig [qf_abbreviate $val $chars_max "" "_"]
+ set label $label_orig
+ set existing_id [qss_tips_table_id_of_label $label]
+ while { ( $existing_id ne "" && $existing_id ne $table_id ) && $i < 1000 } {
+ incr i
+ set chars_max [expr { 38 - [string length $i] } ]
+ set label [string range $label_orig 0 $chars_max]
+ append label "-" $i
+ set existing_id [qss_tips_table_id_of_label $label]
+ }
+ }
+ }
+ }
+ }
+ }
+ if { $changed_p } {
+ qss_tips_user_id_set
+ db_transaction {
+ # trash record
+ qss_tips_table_def_trash $table_id
+ # create new
+ set trashed_p 0
+ db_dml tips_table_def_log_rev {
+ insert into qss_tips_table_defs
+ (instance_id,id,label,name,flags,user_id,created,trashed_p)
+ values (:instance_id,:table_id,:label,:name,:flags,:user_id,now(),:trashed_p)
+ }
+ }
+ }
+ }
+ return $exists_p
+}
+
+ad_proc -public qss_tips_table_def_trash {
+ table_id
+} {
+ Trashes a tips table by table_id.
+
+ @return 1 if success, otherwise return 0.
+} {
+ upvar 1 instance_id instance_id
+ qss_tips_user_id_set
+ set success_p [qss_tips_table_id_exists_q $table_id]
+ if { $success_p } {
+ db_dml qss_tips_table_trash {
+ update qss_tips_table_defs
+ set trashed_p='1',trashed_by=:user_id,trashed_dt=now()
+ where id=:table_id
+ and instance_id=:instance_id
+ }
+ }
+ return $success_p
+}
+
+
+ad_proc -public qss_tips_table_read_as_array {
+ name_array
+ table_label
+ {vc1k_search_label_val_list ""}
+ {row_id_list ""}
+} {
+ Returns one or more records of table_label as an array
+ where field value pairs in vc1k_search_label_val_list match query.
+
+ Array indexes are name_array(row_id,field_label)
+ where row_id are in a list in name_array(row_ids).
+
+ If row_id_list contains row_ids, only returns ids that are supplied in row_id_list.
+
+ name_array(row_ids) contains a list of row_ids used for array indexes.
+
+ name_array(labels) contains a list of table labels (ie columns)
+} {
+ # Returns an array instead of list of lists in order to avoid sorting row_ids.
+
+ # Querying Trashed_p = 1 doesn't make sense, because row_id and field_id are same ref..
+ # trashed_p only makes sense if calling up history of a single cell, row, or table.. by activity.
+ upvar 1 instance_id instance_id
+ upvar 1 $name_array n_arr
+ set table_id [qss_tips_table_id_of_label $table_label]
+ set success_p 0
+
+ if { [qf_is_natural_number $table_id] } {
+ set count [qss_tips_field_defs_maps_set $table_id "" field_id_arr type_arr label_arr field_ids_list field_labels_list]
+ if { $count > 0 } {
+ set row_ids_sql ""
+ if { $row_id_list ne "" } {
+ # filter to row_id_list
+ if { [hf_natural_number_list_validate $row_id_list] } {
+ set row_ids_sql "and row_id in ([template::util::tcl_to_sql_list $row_id_list])"
+ } else {
+ ns_log Warning "qss_tips_read.31: One or more row_id are not a natural number '${row_id_list}'"
+ set row_ids_sql "na"
+ }
+ }
+ set vc1k_search_sql ""
+ if { $vc1k_search_label_val_list ne "" } {
+ # search scope
+ set vc1k_search_lv_list [qf_listify $vc1k_search_label_val_list]
+ set vref 0
+ foreach {label vc1k_search_val} $vc1k_search_lv_list {
+ incr vref
+ if { [info exists field_id_arr(${label}) ] && $vc1k_search_sql ne "na" } {
+ set field_id $field_id_arr(${label})
+ if { $vc1k_search_val eq "" } {
+ append vc1k_search_sql " and row_id in ("
+ append vc1k_search_sql "select row_id from qss_tips_field_values
+ where table_id=:table_id
+ and trashed_p!='1'
+ and row_id not in ("
+ append vc1k_search_sql "select row_id from qss_tips_field_values
+ where table_id=:table_id
+ and f_vc1k is not null
+ and field_id='"
+ append vc1k_search_sql $field_id "' and trashed_p!='1') group by row_id)"
+ } else {
+ #set field_id $field_id_arr(${label})
+ set vc1k_val_${vref} $vc1k_search_val
+ append vc1k_search_sql " and (field_id='" $field_id "' and f_vc1k=:vc1k_val_${vref})"
+ }
+ } else {
+ ns_log Warning "qss_tips_read.492: no field_id for search label '${label}' \
+ table_label '${table_label}' "
+ set vc1k_search_sql "na"
+ }
+ }
+ }
+
+ if { $row_ids_sql eq "na" || $vc1k_search_sql eq "na" } {
+ set n_arr(row_ids) [list ]
+ set n_arr(labels) [list ]
+ } else {
+ set db_sql "select row_id, field_id, f_vc1k, f_nbr, f_txt \
+ from qss_tips_field_values \
+ where table_id=:table_id \
+ and instance_id=:instance_id \
+ and trashed_p!='1' \
+ and field_id in ([template::util::tcl_to_sql_list $field_ids_list]) \
+ ${vc1k_search_sql} ${row_ids_sql}"
+ set values_lists [db_list_of_lists qss_tips_field_values_r $db_sql]
+ # How to set all values for a row_id without sorting?
+ # Answer: set all cases to empty string..
+ # And yet that may double the cases of setting vars.
+ # By sorting by row_id, loops can be combined, and scalar and list vars used.
+ set values_by_row_lists [lsort -integer -index 0 $values_lists]
+ # For missing cases that need to be set to empty string.
+ set es ""
+
+ # val_i = values initial
+ set row_ids_list [list ]
+ set field_ids_used_list [list ]
+ set row_id_prev ""
+ foreach cell_list $values_by_row_lists {
+ foreach {row_id field_id f_vc1k f_nbr f_txt} $cell_list {
+ if { $row_id ne $row_id_prev } {
+ # new row_id.
+ # Add any missing cells for previous row
+ if { $row_id_prev ne "" } {
+ set field_ids_blank_list [set_difference $field_ids_list $field_ids_used_list]
+ if { [llength $field_ids_blank_list] > 0 } {
+ set v ""
+ set row_id_comma $row_id_prev
+ append row_id_comma ","
+ foreach f_id $field_ids_blank_list {
+ set row_id_label $row_id_comma
+ append row_id_label $label_arr(${f_id})
+ set n_arr(${row_id_label}) $v
+ }
+ }
+
+ }
+ # Start new row processing
+ lappend row_ids_list $row_id
+ set field_ids_used_list [list ]
+ }
+
+ if { [info exists type_arr(${field_id}) ] } {
+ # set field_type $type_arr(${field_id})
+ set v [qss_tips_value_of_field_type $type_arr(${field_id}) $f_nbr $f_txt $f_vc1k]
+ } else {
+ ns_log Warning "qss_tips_read.54: field_id does not have a field_type. \
+ table_label '${table_label}' field_id '${field_id}' row_id '${row_id}'"
+ set v [qal_first_nonempty_in_list [list $f_nbr $f_vc1k $f_txt]]
+ }
+ lappend field_ids_used_list $field_id
+ set row_id_label $row_id
+ append row_id_label "," $label_arr(${field_id})
+ set n_arr(${row_id_label}) $v
+ set row_id_prev $row_id
+ }
+ }
+ # process last row blanks, if any
+ if { $row_id_prev ne "" } {
+ set field_ids_blank_list [set_difference $field_ids_list $field_ids_used_list]
+ if { [llength $field_ids_blank_list] > 0 } {
+ set v ""
+ set row_id_comma $row_id_prev
+ append row_id_comma ","
+ foreach f_id $field_ids_blank_list {
+ set row_id_label $row_id_comma
+ append row_id_label $label_arr(${f_id})
+ set n_arr(${row_id_label}) $v
+ }
+ }
+
+ }
+
+
+
+ set n_arr(row_ids) $row_ids_list
+ set n_arr(labels) $field_labels_list
+ if { [llength $row_ids_list] > 0 } {
+ set success_p 1
+ }
+ }
+ }
+ }
+ return $success_p
+}
+
+ad_proc -public qss_tips_table_read {
+ table_label
+ {vc1k_search_label_val_list ""}
+ {row_id_list ""}
+ {row_id_column_name ""}
+} {
+ Returns one or more records of table_label as a list of lists
+ where field value pairs in vc1k_search_label_val_list match query.
+
+ First row contains table labels cooresponding to values in subsequent rows.
+
+ If row_id_list contains row_ids, only returns ids that are supplied in row_id_list.
+
+ If row_id_column_name is supplied,
+ a column containing row_id for each row will be appended to the table.
+ The label name will be the one supplied to row_id_column_name
+} {
+ upvar 1 instance_id instance_id
+ set table_id [qss_tips_table_id_of_label $table_label]
+ set success_p 0
+ set table_lists [list ]
+ if { [qf_is_natural_number $table_id] } {
+ set label_ids_list_len [qss_tips_field_defs_maps_set $table_id "" field_id_arr type_arr label_arr label_ids_list labels_list]
+ if { $label_ids_list_len > 0 } {
+
+ set label_ids_sorted_list [lsort -integer $label_ids_list]
+ set titles_list [list ]
+
+ foreach id $label_ids_sorted_list {
+ set label $label_arr(${id})
+ lappend titles_list $label
+ }
+ if { [hf_are_safe_and_printable_characters_q $row_id_column_name ] } {
+ set row_id_column_name_exists_p 1
+ lappend titles_list $row_id_column_name
+ } else {
+ set row_id_column_name_exists_p 0
+ }
+ lappend table_lists $titles_list
+
+ set row_ids_sql ""
+ if { $row_id_list ne "" } {
+ # filter to row_id_list
+ if { [hf_natural_number_list_validate $row_id_list] } {
+ set row_ids_sql "and row_id in ([template::util::tcl_to_sql_list $row_id_list])"
+ } else {
+ ns_log Warning "qss_tips_read.31: One or more row_id are not a natural number '${row_id_list}'"
+ set row_ids_sql "na"
+ }
+ }
+ set vc1k_search_sql ""
+ if { $vc1k_search_label_val_list ne "" } {
+ # search scope
+ set vc1k_search_lv_list [qf_listify $vc1k_search_label_val_list]
+ set vref 0
+ foreach {label vc1k_search_val} $vc1k_search_lv_list {
+ incr vref
+ if { [info exists field_id_arr(${label}) ] && $vc1k_search_sql ne "na" } {
+ set field_id $field_id_arr(${label})
+
+ if { $vc1k_search_val eq "" } {
+ # append vc1k_search_sql " and (field_id='" $field_id "' and f_vc1k is null)"
+ append vc1k_search_sql " and row_id in ("
+ append vc1k_search_sql "
+ select row_id from qss_tips_field_values
+ where table_id=:table_id
+ and trashed_p!='1'
+ and row_id not in ("
+ append vc1k_search_sql "
+ select row_id from qss_tips_field_values
+ where table_id=:table_id
+ and f_vc1k is not null
+ and field_id='"
+ append vc1k_search_sql $field_id "' and trashed_p!='1') group by row_id)"
+ } else {
+ set vc1k_val_${vref} $vc1k_search_val
+ append vc1k_search_sql " and (field_id='" $field_id "' and f_vc1k=:vc1k_val_${vref})"
+ }
+ } else {
+ ns_log Warning "qss_tips_read.571: no field_id for search label '${label}' \
+ table_label '${table_label}' "
+ set vc1k_search_sql "na"
+ }
+ }
+ }
+
+ if { $row_ids_sql eq "na" || $vc1k_search_sql eq "na" } {
+ # do nothing
+ } else {
+ set db_sql "\
+ select row_id, field_id, f_vc1k, f_nbr, f_txt from qss_tips_field_values \
+ where table_id=:table_id \
+ and instance_id=:instance_id \
+ and trashed_p!='1' ${vc1k_search_sql} ${row_ids_sql} order by row_id, field_id asc"
+ set values_lists [db_list_of_lists qss_tips_field_values_r_sorted $db_sql]
+
+ set row_list [list ]
+ set start_cell_list [lindex $values_lists 0]
+ set current_row_id [lindex $start_cell_list 0]
+ set f_idx 0
+ set current_field_id [lindex $label_ids_sorted_list $f_idx]
+
+ foreach cell_list $values_lists {
+ foreach {row_id field_id f_vc1k f_nbr f_txt} $cell_list {
+ if { $row_id ne $current_row_id } {
+
+
+ while { $f_idx < $label_ids_list_len } {
+ # add blank cell
+ lappend row_list ""
+
+ incr f_idx
+ set current_field_id [lindex $label_ids_sorted_list $f_idx]
+ }
+
+ if { $row_id_column_name_exists_p } {
+ lappend row_list $current_row_id
+ }
+
+ lappend table_lists $row_list
+
+ # new row
+ set fid_list [list ]
+ set f_idx_list [list ]
+ set row_list [list ]
+ set current_row_id $row_id
+ set f_idx 0
+ set current_field_id [lindex $label_ids_sorted_list $f_idx]
+ }
+ if { ![qf_is_natural_number $field_id] || ![qf_is_natural_number $current_field_id] } {
+ ns_log Warning "qss_tips_table_read.754: field_id '${field_id} current_field_id '${current_field_id}' This should not happen."
+ }
+ while { $field_id > $current_field_id && $f_idx < $label_ids_list_len } {
+ # add blank cell
+ lappend row_list ""
+
+ incr f_idx
+ set current_field_id [lindex $label_ids_sorted_list $f_idx]
+ }
+ if { [info exists type_arr(${field_id}) ] } {
+ set v [qss_tips_value_of_field_type $type_arr(${field_id}) $f_nbr $f_txt $f_vc1k]
+ } else {
+ ns_log Warning "qss_tips_read.54: field_id does not have a field_type. \
+ table_label '${table_label}' field_id '${field_id}' row_id '${row_id}'"
+ set v [qal_first_nonempty_in_list [list $f_nbr $f_vc1k $f_txt]]
+ }
+ # label $label_arr(${field_id})
+ # v is value
+ lappend row_list $v
+
+ incr f_idx
+ set current_field_id [lindex $label_ids_sorted_list $f_idx]
+ }
+ }
+
+ if { [llength $row_list] > 0 } {
+
+ while { $f_idx < $label_ids_list_len } {
+ # add blank cell
+ lappend row_list ""
+
+ incr f_idx
+ # following not needed for these cases.
+ #set current_field_id \[lindex $label_ids_sorted_list $f_idx\]
+ }
+
+ if { $row_id_column_name_exists_p } {
+ lappend row_list $current_row_id
+ }
+
+ lappend table_lists $row_list
+ }
+ }
+ }
+ }
+ return $table_lists
+}
+
+
+
+ad_proc -public qss_tips_field_def_create {
+ args
+} {
+ Adds a field to an existing table.
+
+ Each field is a column in a table.
+
+ args is passed in name value pairs.
+
+ Requires table_label or table_id and field: label name tdt_data_type field_type.
+
+ default_val and tdt_dat_type are empty strings unless supplied.
+
+ field_type defaults to txt.
+
+ field_type is one of 'txt', 'vc1k', or 'nbr';
+ -
+
txt is of data type "text",
+ -
+
nbr is of type numeric, and
+ -
+
vc1k is of type varchar(1000).
+
+
+ Searches are fastest on vc1k types as these entries are indexed in the data model.
+
+ tdt_data_type references an entry in qss_tips_data_types.
+
+ @return field_def_id or empty string if unsuccessful.
+} {
+ upvar 1 instance_id instance_id
+ qss_tips_user_id_set
+
+ # Allow args to be passed as a list or separate parameters
+ set args_list [list ]
+ set arg1 [lindex $args 0]
+ if { [llength $arg1] > 1 } {
+ set args_list $arg1
+ }
+ set args_list [concat $args_list $args]
+ # req = required
+ set req_list [list label name]
+ set opt_list [list default_val tdt_data_type field_type]
+ set xor_list [list table_id table_label]
+ set all_list [concat $req_list $opt_list $xor_list]
+ set name_list [list ]
+
+ set field_types_list [list txt vc1k nbr]
+ set new_id ""
+ # optional values have defaults
+ set default_val ""
+ set tdt_data_type ""
+ set field_type "txt"
+
+ foreach {nam val} $args_list {
+ if { $nam in $all_list } {
+ if { $nam eq "field_type" && $val ni $field_types_list } {
+ # use default
+ } else {
+ set $nam $val
+ lappend name_list $nam
+ }
+ }
+ }
+ set success_p 1
+ foreach nam $req_list {
+ if { $nam ni $name_list } {
+ set success_p 0
+ }
+ }
+ if { $success_p && ( "table_id" ni $name_list && "table_label" ni $name_list ) } {
+ set success_p 0
+ }
+ if { $success_p } {
+ # since optional values have defaults, no need to customize sql
+ if { ![info exists table_id] } {
+ set table_id [qss_tips_table_id_of_label $table_label]
+ }
+ set trashed_p 0
+ if { [qf_is_natural_number $table_id] } {
+ set new_id [db_nextval qss_tips_id_seq]
+ db_dml qss_tips_field_def_cr {insert into qss_tips_field_defs
+ (instance_id,id,table_id,created,user_id,label,name,default_val,
+ tdt_data_type,field_type,trashed_p)
+ values (:instance_id,:new_id,:table_id,now(),:user_id,:label,:name,:default_val,
+ :tdt_data_type,:field_type,:trashed_p)
+ }
+ }
+ }
+ return $new_id
+}
+
+
+ad_proc -public qss_tips_field_def_trash {
+ field_ids
+ table_id
+} {
+ Trashes one or more fields.
+
+ Each field is a column in a table.
+
+ Accepts list or scalar value.
+
+ If table_id is supplied, scopes to table_id.
+
+ @return 1 if all cases are success, otherwise returns 0.
+} {
+ upvar 1 instance_id instance_id
+ qss_tips_user_id_set
+ set field_ids_list [qf_listify $field_ids]
+ set success_p_tot 1
+ foreach field_id $field_ids_list {
+ set success_p [qss_tips_field_def_id_exists_q $field_id $table_id]
+ set success_p_tot [expr { $success_p && $success_p_tot } ]
+ if { $success_p } {
+ db_dml qss_tips_field_trash_def1 {
+ update qss_tips_field_defs
+ set trashed_p='1',trashed_by=:user_id,trashed_dt=now()
+ where id=:field_id
+ and table_id=:table_id
+ and instance_id=:instance_id}
+ }
+ }
+ return $success_p_tot
+}
+
+ad_proc -public qss_tips_field_def_update {
+ table_id
+ args
+} {
+ Given table_id and field_id or field_label, updates label and/or name.
+
+ args can be passed as list or list of args in name value pairs.
+
+ Acceptable names are field_id or field_label for referencing field;
+ and name_new and/or label_new for setting new values for referenced names.
+
+ @return 1 if successful, otherwise return 0.
+} {
+ upvar 1 instance_id instance_id
+ set success_p 0
+
+ # Allow args to be passed as a list or separate parameters
+ set args_list [list ]
+ set arg1 [lindex $args 0]
+ if { [llength $arg1] > 1 } {
+ set args_list $arg1
+ }
+ set args_list [concat $args_list $args]
+
+ set includes_ref_p 0
+ set includes_set_p 0
+ set names_list [list field_id field_label name_new label_new]
+ set ref_list [list field_id field_label]
+ foreach {n v} $args_list {
+ if { $n in $names_list } {
+ set $n $v
+ if { $n in $ref_list } {
+ set includes_ref_p 1
+ } else {
+ set includes_set_p 1
+ }
+ }
+ }
+ if { $includes_ref_p && $includes_set_p } {
+
+ if { [info exists field_id] } {
+ set extra_ref_sql "and id=:field_id"
+ } elseif { [info exists field_label] } {
+ set extra_ref_sql "and label=:field_label"
+ }
+
+ set db_sql "select id as field_id,label,name,default_val,tdt_data_type,\
+ field_type,created as c_date,user_id as c_user_id from qss_tips_field_defs \
+ where instance_id=:instance_id \
+ and table_id=:table_id \
+ and trashed_p!='1' ${extra_ref_sql}"
+ set exists_p [db_0or1row qss_tips_field_def_r_u1 $db_sql]
+ if { $exists_p } {
+ qss_tips_user_id_set
+ if { ![info exists name_new] } {
+ set name_new $name
+ }
+ if { ![info exists label_new] } {
+ set label_new $label
+ }
+ set trashed_p 0
+ db_transaction {
+ db_dml qss_tips_field_def_u1 { update qss_tips_field_defs
+ set trashed_p='1',
+ trashed_dt=now(),
+ trashed_by=:user_id
+ where id=:field_id
+ and instance_id=:instance_id
+ and table_id=:table_id }
+ db_dml qss_tips_field_def_u1_cr {
+ insert into qss_tips_field_defs
+ (instance_id,table_id,id,label,name,user_id,created,
+ trashed_p,default_val,tdt_data_type,field_type)
+ values (:instance_id,:table_id,:field_id,:label_new,:name_new,
+ :user_id,now(),:trashed_p,:default_val,:tdt_data_type,:field_type)
+ }
+ }
+ set success_p 1
+ }
+ }
+ return $success_p
+}
+
+
+ad_proc -private qss_tips_field_def_read {
+ table_id
+ {field_labels ""}
+ {field_ids ""}
+} {
+ Reads definitions about fields in a table.
+
+ Returns an ordered list of lists, where colums are:
+
+ field_id,label,name,default_val,tdt_data_type,field_type
+
+ or empty list if not found.
+
+ If field_labels or field_ids is nonempty (list or scalar), scopes to just these.
+} {
+ upvar 1 instance_id instance_id
+ set fields_lists [list ]
+ if {[qf_is_natural_number $table_id ]} {
+ set db_sql {
+ select id as field_id,label,name,default_val,tdt_data_type,field_type from qss_tips_field_defs
+ where instance_id=:instance_id
+ and table_id=:table_id
+ and trashed_p!='1'}
+ set fields_lists [db_list_of_lists qss_tips_field_defs_r $db_sql]
+ # allow glob with field_labels
+ set field_label_idx_list [list ]
+ set field_label_list [qf_listify $field_labels]
+ set field_label_list_len [llength $field_label_list]
+ #ns_log Notice "qss_tips_field_def_read.790 field_label_list '${field_label_list}'
+ # field_label_list_len '${field_label_list_len}'"
+ if { $field_label_list_len > 0 } {
+ # create a searchable list
+ set label_search_list [list ]
+ foreach field_list $fields_lists {
+ lappend label_search_list [lindex $field_list 1]
+ }
+ foreach field_label $field_label_list {
+ set indexes [lsearch -all -glob $label_search_list $field_label]
+ set field_label_idx_list [concat $field_label_idx_list $indexes]
+ }
+
+ }
+
+ set field_id_idx_list [list ]
+ set field_id_list [hf_list_filter_by_natural_number [qf_listify $field_ids]]
+ set field_id_list_len [llength $field_id_list]
+ #ns_log Notice "qss_tips_field_def_read.808 field_id_list '${field_id_list}'
+ # field_id_list_len '${field_id_list_len}'"
+ if { $field_id_list_len > 0 } {
+ # create a searchable list
+ set id_search_list [list ]
+ foreach field_list $fields_lists {
+ lappend id_search_list [lindex $field_list 0]
+ }
+ foreach id $field_id_list {
+ set indexes [lsearch -exact -all -integer $id_search_list $id]
+ set field_id_idx_list [concat $field_id_idx_list $indexes]
+ }
+ }
+
+ if { $field_id_list_len > 0 || $field_label_list_len > 0 } {
+ set field_idx_list [concat $field_id_idx_list $field_label_idx_list]
+ # remove duplicates
+ set field_idx_list [qf_uniques_of $field_idx_list]
+ # scope fields_lists to just the filtered ones
+ set filtered_lists [list ]
+ foreach fid $field_idx_list {
+ lappend filtered_lists [lindex $fields_lists $fid]
+ }
+ set fields_lists $filtered_lists
+ }
+ }
+ return $fields_lists
+}
+
+
+
+ad_proc -public qss_tips_row_create {
+ table_id
+ args
+} {
+ Writes a record into table_label.
+
+ Returns row_id if successful, otherwise empty string.
+
+ args can be passed as name value list or parameters.
+
+ Missing field labels are left blank ie. no default_value subistituion is performed.
+} {
+ upvar 1 instance_id instance_id
+ # args was label_value_list
+ # Allow args to be passed as a list or separate parameters
+ set label_value_list [list ]
+ set arg1 [lindex $args 0]
+ if { [llength $arg1] > 1 } {
+ set label_value_list $arg1
+ }
+ set label_value_list [concat $label_value_list $args]
+ set new_id ""
+ if { [qf_is_natural_number $table_id] } {
+ set count [qss_tips_field_defs_maps_set $table_id t_arr l_arr "" "" "" field_labels_list]
+ # field_labels_list defined.
+ if { $count > 0 } {
+ qss_tips_user_id_set
+ set new_id [db_nextval qss_tips_id_seq]
+ db_transaction {
+ foreach {label value} $label_value_list {
+ # if field value is blank, skip..
+ if { $label in $field_labels_list && $value ne "" } {
+ set field_id $l_arr(${label})
+ set field_type $t_arr(${label})
+ set trashed_p 0
+ qss_tips_set_by_field_type $field_type $value f_nbr f_txt f_vc1k
+ ns_log Notice "qss_tips_row_create.911: field_type '${field_type}' \
+ value '${value}' f_nbr '${f_nbr}' f_txt '${f_txt}' f_vc1k '${f_vc1k}'"
+ set db_sql {
+ insert into qss_tips_field_values
+ (instance_id,table_id,row_id,trashed_p,created,
+ user_id,field_id,f_vc1k,f_nbr,f_txt)
+ values (:instance_id,:table_id,:new_id,:trashed_p,now(),
+ :user_id,:field_id,:f_vc1k,:f_nbr,:f_txt) }
+ db_dml qss_tips_field_values_row_cr_1f $db_sql
+ }
+ }
+ }
+ } else {
+ ns_log Notice "qss_tips_row_create.908: No fields defined for table_id '${table_id}'."
+ }
+ } else {
+ ns_log Notice "qss_tips_row_create.911: table_id '${table_id}' not a valid number."
+ }
+ return $new_id
+}
+
+ad_proc -private qss_tips_value_of_field_type {
+ field_type
+ f_nbr
+ f_txt
+ f_vc1k
+} {
+ Returns value based on field_type.
+} {
+ switch -exact -- $field_type {
+ vc1k { set v $f_vc1k }
+ nbr { set v $f_nbr }
+ txt { set v $f_txt }
+ default {
+ set v [qal_first_nonempty_in_list [list $f_nbr $f_vc1k $f_txt]]
+ ns_log Warning "qss_tips_value_of_field_type.843: unknown field_type '${field_type}'. \
+ Choosing first nonempty value: '${v}'"
+ }
+ }
+ return $v
+}
+
+ad_proc -private qss_tips_set_by_field_type {
+ field_type
+ value
+ nbr_var_name
+ txt_var_name
+ vc1k_var_name
+} {
+ Sets value to appropriate variable based on field_type.
+
+ Others are set to empty string.
+} {
+ upvar 1 $nbr_var_name f_nbr
+ upvar 1 $txt_var_name f_txt
+ upvar 1 $vc1k_var_name f_vc1k
+ set success_p 1
+ switch -exact -- $field_type {
+ vc1k {
+ set f_nbr ""
+ set f_txt ""
+ set f_vc1k $value
+ }
+ nbr {
+ set f_nbr $value
+ set f_txt ""
+ set f_vc1k ""
+ }
+ txt {
+ set f_nbr ""
+ set f_txt $value
+ set f_vc1k ""
+ }
+ default {
+ ns_log Warning "qss_tips_set_by_field_type.783: field_type '${field_type}' not valid. \
+ Defaulting to txt"
+ set f_nbr ""
+ set f_txt $value
+ set f_vc1k ""
+ set success_p 0
+ }
+ }
+ ns_log Notice "qss_tips_set_by_field_type.984: field_type '${field_type}' value '${value}' \
+ f_nbr '${f_nbr}' f_txt '${f_txt}' f_vc1k '${f_vc1k}'"
+ return $success_p
+}
+
+
+ad_proc -public qss_tips_row_update {
+ table_id
+ row_id
+ label_value_list
+} {
+ Updates a record into table_label.
+
+ @return 1 if successful, otherwise return 0.
+} {
+ upvar 1 instance_id instance_id
+ set success_p 0
+ if { [qf_is_natural_number $table_id] && [qf_is_natural_number $row_id ] } {
+ set success_p [qss_tips_row_id_exists_q $row_id $table_id ]
+ if { $success_p } {
+ set count [qss_tips_field_defs_maps_set $table_id t_arr l_arr "" "" "" field_labels_list ]
+ if { $count > 0 } {
+ qss_tips_user_id_set
+ db_transaction {
+ foreach {label value} $label_value_list {
+ if { $label in $field_labels_list } {
+ #set field_id $l_arr(${label})
+ #set field_type $t_arr(${label})
+ ns_log Notice "qss_tips_row_update.1027 table_id '${table_id}' \
+ row_id '${row_id}' label '${label}' t_arr(${label}) '$t_arr(${label})'"
+ qss_tips_set_by_field_type $t_arr(${label}) $value f_nbr f_txt f_vc1k
+ qss_tips_cell_update $table_id $row_id $l_arr(${label}) $value
+ } else {
+ ns_log Notice "qss_tips_row_update.1031 label '${label}' \
+ not in table_id '${table_id}'. update to value '${value}' ignored."
+ }
+ }
+ }
+ }
+ }
+ } else {
+ ns_log Warning "qss_tips_row_udpate.1035: table_id '${table_id}' \
+ or row_id '${row_id}' is not a number."
+ }
+ return $success_p
+}
+
+
+
+ad_proc -public qss_tips_row_of_table_label_value {
+ table_id
+ {vc1k_search_label_val_list ""}
+ {if_multiple "1"}
+ {row_id_var_name ""}
+} {
+ Reads a row from table_id as a name_value_list.
+
+ If more than one row matches, returns 1 row based on value of choosen:
+
-
+ -1 = return empty row
+
-
+ 0 = row based on earliest value of label
+
-
+ 1 = row based on latest value of label
+
+ If row_id_var_name is not empty string, assigns the row_id to that variable name.
+
+ @return name_value_list
+} {
+ upvar 1 instance_id instance_id
+ if { $row_id_var_name ne "" } {
+ upvar 1 $row_id_var_name return_row_id
+ }
+ set return_row_id ""
+ set row_list [list ]
+ if { [qf_is_natural_number $table_id] } {
+ # field_ids_list and field_labels_list are coorelated 1:1
+ set label_ids_list_len [qss_tips_field_defs_maps_set $table_id "" field_id_arr type_arr label_arr field_ids_list ""]
+ if { $label_ids_list_len > 0 } {
+ set vc1k_search_sql ""
+ set sort_sql ""
+ switch -exact -- $if_multiple {
+ 1 {
+ # LIFO
+ set sort_sql "order by created desc"
+ }
+ -1 {
+ # Reject multiple
+ set sort_sql "order by created asc"
+ }
+ 0 -
+ default {
+ # FIFO is safest/most reliable. No?
+ set sort_sql "order by created asc"
+ set if_multiple "0"
+ }
+ }
+
+
+ if { $vc1k_search_label_val_list ne "" } {
+ # search scope
+ set vc1k_search_lv_list [qf_listify $vc1k_search_label_val_list]
+ ns_log Notice "qss_tips_row_of_table_label_value.1056: vc1k_search_label_val_list \
+ '${vc1k_search_label_val_list}' vc1k_search_lv_list '${vc1k_search_lv_list}'"
+ set vref 0
+ foreach {label vc1k_search_val} $vc1k_search_lv_list {
+ incr vref
+ if { [info exists field_id_arr(${label}) ] && $vc1k_search_sql ne "na" } {
+ if { $vc1k_search_val eq "" } {
+ #change to add an expression that limits results to row_ids from a general query of
+ # row_ids less row_ids of field_id that have values.
+ # because null and empty values don't exist in table's db.
+ append vc1k_search_sql " and row_id in ("
+ append vc1k_search_sql "select row_id from qss_tips_field_values \
+ where table_id=:table_id \
+ and trashed_p!='1' \
+ and row_id not in ("
+ append vc1k_search_sql "select row_id from qss_tips_field_values \
+ where table_id=:table_id \
+ and f_vc1k is not null \
+ and field_id='"
+ append vc1k_search_sql $field_id_arr(${label})
+ append vc1k_search_sql "' and trashed_p!='1') group by row_id)"
+ } else {
+ #set field_id $field_id_arr(${label})
+ set vc1k_val_${vref} $vc1k_search_val
+ append vc1k_search_sql " and (field_id='" $field_id_arr(${label})
+ append vc1k_search_sql "' and f_vc1k=:vc1k_val_${vref})"
+ }
+ } else {
+ ns_log Warning "qss_tips_row_of_table_label_value.1067: no field_id \
+ for search label '${label}' table_id '${table_id}' "
+ set vc1k_search_sql "na"
+ }
+ }
+ } else {
+ set vck1_search_sql "na"
+ }
+
+ if { $vc1k_search_sql eq "na" } {
+ # do nothing
+ } else {
+ # get row id, then row
+ ns_log Notice "qss_tips_row_of_table_label_value.1084: \
+ vc1k_search_sql '${vc1k_search_sql}' sort_sql '${sort_sql}'"
+ set db_sql "\
+ select row_id from qss_tips_field_values \
+ where instance_id=:instance_id \
+ and table_id=:table_id \
+ and trashed_p!='1' ${vc1k_search_sql} ${sort_sql}"
+ set row_ids_list [db_list qss_tips_field_values_row_id_search $db_sql]
+ set row_id [lindex $row_ids_list 0]
+ if { $row_id ne "" } {
+ set exists_p 1
+ } else {
+ set exists_p 0
+ }
+ if { $exists_p && $if_multiple eq "-1" } {
+ set row_ids_unique_list [qf_uniques_of $row_ids_list]
+ if { [llength $row_ids_unique_list] > 1 } {
+ ns_log Notice "qss_tips_row_of_table_label_value.1094: Rejecting row_id,\
+ because if_multiple=-1: row_ids_list '${row_ids_list}' row_ids_unique_list '${row_ids_unique_list}'"
+ #set return_row_id ""
+ set exists_p 0
+ }
+ }
+
+ if { $exists_p } {
+ # duplicate core of qss_tips_row_read
+ set return_row_id $row_id
+ set db_sql {
+ select field_id, row_id, f_vc1k, f_nbr, f_txt
+ from qss_tips_field_values
+ where table_id=:table_id
+ and row_id=:row_id
+ and instance_id=:instance_id
+ and trashed_p!='1'}
+ set values_lists [db_list_of_lists qss_tips_field_values_r1m $db_sql]
+
+ set used_fields_list [list ]
+ foreach row $values_lists {
+ foreach {field_id row_id f_vc1k f_nbr f_txt} $row {
+ if { [info exists type_arr(${field_id}) ] } {
+ set v [qss_tips_value_of_field_type $type_arr(${field_id}) $f_nbr $f_txt $f_vc1k]
+ } else {
+ ns_log Warning "qss_tips_row_of_table_label_value.1092: field_id \
+ does not have a field_type. table_id '${table_id}' field_id '${field_id}' row_id '${row_id}'"
+ }
+ # label $label_arr(${field_id})
+ lappend row_list $label_arr(${field_id}) $v
+ lappend used_fields_list $field_id
+ }
+ }
+ set_difference_named_v field_ids_list $used_fields_list
+ foreach field_id $field_ids_list {
+ lappend row_list $label_arr(${field_id}) ""
+ }
+
+ } else {
+ ns_log Notice "qss_tips_row_of_table_label_value.1099: row not found \
+ for search '${vc1k_search_label_val_list}'."
+ }
+ }
+ } else {
+ ns_log Notice "qss_tips_row_of_table_label_value.1101: no fields defined for table_id '${table_id}'"
+ }
+ } else {
+ ns_log_ Notice "qss_tips_row_of_table_label_value.1104: table_id '${table_id}' not a natural number."
+ }
+ return $row_list
+}
+
+ad_proc -public qss_tips_rows_read {
+ table_id
+ row_ids_list
+} {
+ Reads rows from table_id as a list of lists.
+
+ The first row consists of a list of ordered field (ie column) labels for subsequent lists.
+
+ row_ids_list is a list of row_ids of table_id.
+
+ Returns empty list if table not found.
+} {
+ upvar 1 instance_id instance_id
+ set rows_lists [list ]
+ if { [qf_is_natural_number $table_id] && [hf_natural_number_list_validate $row_ids_list] } {
+ set count [qss_tips_field_defs_maps_set $table_id "" "" type_arr label_arr "" labels_list]
+ if { $count > 0 } {
+ lappend rows_lists $labels_list
+ set db_sql "select field_id, row_id, f_vc1k, f_nbr, f_txt from qss_tips_field_values \
+ where table_id=:table_id \
+ and instance_id=:instance_id \
+ and trashed_p!='1' \
+ and row_id in ([template::util::tcl_to_sql_list $row_id_list])"
+ set values_lists [db_list_of_lists qss_tips_field_values_r_mult $db_sql]
+ set values_lists [lsort -integer -index 1 $values_lists]
+ set row_id [lindex [lindex $values_lists 0] 1]
+ set row_id_prev $row_id
+ set row_list [list ]
+ foreach row $values_lists {
+ foreach {field_id row_id f_vc1k f_nbr f_txt} $row {
+ if { [info exists type_arr(${field_id}) ] } {
+ set v [qss_tips_value_of_field_type $type_arr(${field_id}) $f_nbr $f_txt $f_vc1k]
+ } else {
+ ns_log Warning "qss_tips_read_from_id.848: field_id does not have a field_type. \
+ table_label '${table_label}' field_id '${field_id}' row_id '${row_id}'"
+ }
+ if { $row_id eq $row_id_prev } {
+ # label $label_arr(${field_id})
+ lappend row_list $label_arr(${field_id}) $v
+ } else {
+ array set row_arr $row_list
+ set row2_list [list ]
+ foreach label $labels_list {
+ if { [info exists row_arr(${label}) ] } {
+ lappend row2_list $row_arr(${label})
+ } else {
+ lappend row2_list ""
+ }
+ }
+ lappend rows_lists $row2_list
+ array unset row_arr
+ set row_list [list ]
+ lappend row_list $label_arr(${field_id}) $v
+ }
+ }
+ }
+ }
+ }
+ return $rows_lists
+}
+
+
+ad_proc -public qss_tips_row_read {
+ table_id
+ row_id
+} {
+ Reads a row from table_id as a name_value_list of field_label1 field_value1 field_label2 field_label2..
+} {
+ upvar 1 instance_id instance_id
+ set row_list [list ]
+ if { [qf_is_natural_number $table_id ] } {
+ set count [qss_tips_field_defs_maps_set $table_id "" "" type_arr label_arr field_ids_list ]
+ if { $count > 0 } {
+ set db_sql {
+ select field_id, row_id, f_vc1k, f_nbr, f_txt from qss_tips_field_values
+ where table_id=:table_id
+ and row_id=:row_id
+ and instance_id=:instance_id
+ and trashed_p!='1'}
+ set values_lists [db_list_of_lists qss_tips_field_values_r $db_sql]
+ set used_fields_list [list ]
+ foreach row $values_lists {
+ foreach {field_id row_id f_vc1k f_nbr f_txt} $row {
+ if { [info exists type_arr(${field_id}) ] } {
+ set v [qss_tips_value_of_field_type $type_arr(${field_id}) $f_nbr $f_txt $f_vc1k]
+ } else {
+ ns_log Warning "qss_tips_row_read.848: field_id does not have a field_type. \
+ table_label '${table_label}' field_id '${field_id}' row_id '${row_id}'"
+ }
+ # label $label_arr(${field_id})
+ lappend row_list $label_arr(${field_id}) $v
+ lappend used_fields_list $field_id
+ }
+ }
+ set_difference_named_v field_ids_list $used_fields_list
+ foreach field_id $field_ids_list {
+ lappend row_list $label_arr(${field_id}) ""
+ }
+ }
+ }
+ return $row_list
+}
+
+ad_proc -public qss_tips_row_trash {
+ table_id
+ row_id
+} {
+ Trashes a record of table_id.
+
+ Returns 1 if successful, otherwise 0.
+} {
+ upvar 1 instance_id instance_id
+ set success_p [qss_tips_row_id_exists_q $row_id $table_id ]
+ if { $success_p } {
+ qss_tips_user_id_set
+ db_dml qss_tips_field_values_row_trash {
+ update qss_tips_field_values
+ set trashed_p='1',trashed_by=:user_id,trashed_dt=now()
+ where row_id=:row_id
+ and table_id=:table_id
+ and instance_id=:instance_id
+ }
+ }
+ return $success_p
+}
+
+ad_proc -public qss_tips_cell_read {
+ table_label
+ vc1k_search_label_val_list
+ return_vals_labels_list
+ {if_multiple "1"}
+ {row_id_var_name __row_id}
+} {
+ Returns the values of the field labels in return_val_label_list in order in list.
+
+ If more than one record matches search_value for search_label, if_multiple
+ determines which one is chosen;
+
+ If present, returns the row_id to the variable called row_id_var_name.
+
+ @see qss_tips_row_of_table_label_value
+} {
+ upvar 1 instance_id instance_id
+ upvar 1 $row_id_var_name row_id
+ set return_val_list [list ]
+ set return_val_label_list [qf_listify $return_vals_labels_list]
+ set return_val_label_list_len [llength $return_val_label_list]
+ if { $return_val_label_list_len > 0 } {
+ set table_id [qss_tips_table_id_of_label $table_label]
+ if { $table_id ne "" } {
+ set label_value_list [qss_tips_row_of_table_label_value $table_id $vc1k_search_label_val_list $if_multiple row_id]
+ set row_labels_list [dict keys $label_value_list]
+ foreach label $return_val_label_list {
+ if { $label in $row_labels_list } {
+ set label_val [dict get $label_value_list $label]
+ } else {
+ set label_val ""
+ }
+ lappend return_val_list $label_val
+ }
+ } else {
+ ns_log Notice "qss_tips_cell_read.1327: table_label not found '${table_label}'"
+ }
+ } else {
+ ns_log Notice "qss_tips_cell_read.1329: No cell labels requested; \
+ No cell values to return for table_label '${table_label}'."
+ }
+
+ # if label_val_label_list is one entry, return a list element only
+ if { $return_val_label_list_len == 1 } {
+ if { [llength $return_val_list] == 0 } {
+ set return_val ""
+ } else {
+ set return_val [lindex $return_val_list 0]
+ }
+ } else {
+ set return_val $return_val_list
+ }
+ return $return_val
+}
+
+ad_proc -private qss_tips_cell_id_exists_q {
+ table_id
+ row_id
+ field_id
+} {
+ Returns 1 if cell exists, otherwise returns 0.
+} {
+ upvar 1 instance_id instance_id
+ set db_sql {
+ select f_vc1k, f_nbr, f_txt from qss_tips_field_values
+ where row_id=:row_id
+ and field_id=:field_id
+ and table_id=:table_id
+ and instance_id=:instance_id
+ and trashed_p!='1'}
+ set exists_p [db_0or1row qss_tips_field_values_c1_by_id $db_sql]
+ return $exists_p
+}
+
+ad_proc -public qss_tips_cell_read_by_id {
+ table_id
+ row_id
+ field_id_list
+} {
+ Returns the values of fields in field_id_list in same order as field_id(s) in list.
+
+ Field_ids without values return empty string.
+
+ Returns the same number of elements in a list as there are in field_id_list.
+} {
+ upvar 1 instance_id instance_id
+ set return_value_list [list ]
+ if { [hf_natural_number_list_validate $field_id_list] } {
+ set field_id_list_len [llength $field_id_list]
+ set db_sql "\
+ select field_id,f_vc1k,f_nbr,f_txt from qss_tips_field_values \
+ where row_id=:row_id \
+ and table_id=:table_id \
+ and instance_id=:instance_id \
+ and trashed_p!='1' \
+ and field_id in ([template::util::tcl_to_sql_list $field_id_list]) "
+ set field_id_values_lists [db_list_of_lists qss_tips_cell_read_by_id $db_sql]
+ ns_log Notice "qss_tips_cell_read_by_id field_id_values_lists '${field_id_values_lists}'"
+ foreach row_list $field_id_values_lists {
+ foreach {field_id f_vc1k f_nbr f_txt} $row_list {
+ # It's faster to assume one value, than query db for field_type
+ set field_value [qal_first_nonempty_in_list [list $f_vc1k $f_nbr $f_txt] ]
+ set v_arr(${field_id}) $field_value
+ ns_log Notice "qss_tips_cell_read_by_id.1384 field_id '$field_id' field_value '${field_value}'"
+ }
+ }
+ ns_log Notice "qss_tips_cell_read_by_id.1387 field_id_list '${field_id_list}'"
+ foreach field_id $field_id_list {
+ set field_value ""
+ ns_log Notice "qss_tips_cell_read_by_id.1390: field_id '${field_id}'"
+ if { [info exists v_arr(${field_id}) ] } {
+ lappend return_value_list $v_arr(${field_id})
+ } else {
+ ns_log Notice "qss_tips_cell_read_by_id.1394: field_id '${field_id}' \
+ not found for row '${row_id}'"
+ lappend return_value_list ""
+ }
+ }
+ ns_log Notice "qss_tips_cell_read_by_id.1396 return_value_list '${return_value_list}'"
+ } else {
+ ns_log Notice "qss_tips_cell_read_by_id.1395 field_id_list did not validate \
+ '${field_id_list}' for table_id '${table_id}'"
+ set field_id_list_len 0
+ }
+ # if label_val_label_list is one entry, return a list element only
+ if { $field_id_list_len == 1 } {
+ if { [llength $return_value_list] == 0 } {
+ set return_val ""
+ } else {
+ set return_val [lindex $return_value_list 0]
+ }
+ } else {
+ set return_val $return_value_list
+ }
+ return $return_val
+}
+
+ad_proc -public qss_tips_cell_update {
+ table_id
+ row_id
+ field_id
+ new_value
+} {
+ Updates a cell value.
+} {
+ upvar 1 instance_id instance_id
+ set success_p 0
+ #set field_info_list \[qss_tips_field_def_read $table_id "" $field_id\]
+ #ns_log Notice "qss_tips_cell_update.1373: field_info_list '${field_info_list}'"
+ #if llength $field_info_list > 0
+ set exists_p [db_0or1row qss_tips_field_def_read_ft {
+ select field_type from qss_tips_field_defs
+ where instance_id=:instance_id
+ and table_id=:table_id
+ and id=:field_id
+ and trashed_p!='1'}]
+ if { $exists_p } {
+ #set field_type \[lindex \[lindex $field_info_list 0\] 5\]
+ qss_tips_set_by_field_type $field_type $new_value f_nbr f_txt f_vc1k
+ qss_tips_user_id_set
+ set trashed_p 0
+ db_transaction {
+ set success_p [qss_tips_cell_trash $table_id $row_id $field_id ]
+ db_dml qss_tips_field_values_row_up_1f { insert into qss_tips_field_values
+ (instance_id,table_id,row_id,trashed_p,created,user_id,field_id,f_vc1k,f_nbr,f_txt)
+ values (:instance_id,:table_id,:row_id,:trashed_p,now(),:user_id,:field_id,:f_vc1k,:f_nbr,:f_txt)
+ }
+ }
+ }
+ return $success_p
+}
+
+ad_proc -public qss_tips_cell_trash {
+ table_id
+ row_id
+ field_id
+} {
+ @return 1 if successful, otherwise 0
+} {
+ upvar 1 instance_id instance_id
+ set exists_p [qss_tips_cell_id_exists_q $table_id $row_id $field_id]
+ if { $exists_p } {
+ qss_tips_user_id_set
+ db_dml qss_tips_field_values_cell_trash { update qss_tips_field_values
+ set trashed_p='1',trashed_by=:user_id,trashed_dt=now()
+ where instance_id=:instance_id
+ and table_id=:table_id
+ and row_id=:row_id
+ and field_id=:field_id }
+ }
+ return $exists_p
+}
Index: openacs-4/packages/spreadsheet/tcl/test/q-control-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/spreadsheet/tcl/test/q-control-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/spreadsheet/tcl/test/q-control-procs.tcl 2 Jan 2017 10:36:06 -0000 1.1
@@ -0,0 +1,445 @@
+ad_library {
+ Automated tests for q-control
+ @creation-date 2015-03-19
+}
+
+aa_register_case -cats {api smoke} qc_hf_permission_check {
+ Test qc_permissions_p proc for all cases
+} {
+ aa_run_with_teardown \
+ -test_code {
+# -rollback \
+ ns_log Notice "aa_register_case.13: Begin test permissions_check"
+ # Use default permissions provided by tcl/q-control-init.tcl
+ # Yet, users must have read access permissions or test fails
+ # Some tests will fail (predictably) in a hardened system
+
+ set instance_id [ad_conn package_id]
+ hf_roles_init $instance_id
+ hf_property_init $instance_id
+ hf_privilege_init $instance_id
+ hf_asset_type_id_init $instance_id
+
+ # Identify and test full range of parameters
+ set asset_type_ids_list [qc_property_list $instance_id]
+ set asset_type_ids_count [llength $asset_type_ids_list]
+ if { $asset_type_ids_count == 0 } {
+ ns_log Error "q-control/tcl/test/q-control-procs.tcl.27: No property to test."
+ }
+ set roles_lists [qc_roles $instance_id]
+ if { [llength $roles_lists ] == 0 } {
+ ns_log Error "q-control/tcl/test/q-control-procs.tcl.31: No role to test."
+ }
+
+ set roles_list [list ]
+ foreach role_list $roles_lists {
+ set role [lindex $role_list 0]
+ lappend roles_list $role
+ set role_id [qc_role_id_of_label $role $instance_id]
+ set role_id_arr(${role}) $role_id
+ }
+ # keep namespace clean to help prevent bugs in test code
+ unset role_id
+ unset role
+ unset roles_lists
+
+ # create a lookup truth table of permissions
+ # qc_asset_type_ids_list vs roles_list
+ # with value being 1 read, 2 create, 4 write, 8 delete, 16 admin
+ # which results in these values, based on existing assignments:
+ # 0,1,3,7,15,31
+ # with this table, if user has same role, customer_id,
+ # then pass using bit math: table value & privilege_request_value
+ #
+ # initialize table
+ foreach role $roles_list {
+ # at_id = asset_type_id
+ foreach at_id $asset_type_ids_list {
+ # 0 is default, no privilege
+ set priv_arr(${role},${at_id}) 0
+ }
+ }
+ # Manually add each entry. This is necessary to avoid duplicating
+ # a code/logic error.
+ array set rp_map_arr [list \
+ site_developer,non_assets 7 \
+ site_developer,published 7 \
+ billing_staff,admin_contact_record 1 \
+ billing_staff,non_assets 1 \
+ billing_staff,published 1 \
+ billing_manager,admin_contact_record 5 \
+ billing_manager,non_assets 5 \
+ billing_manager,published 5 \
+ billing_admin,admin_contact_record 23 \
+ billing_admin,non_assets 23 \
+ billing_admin,published 23 \
+ technical_staff,assets 1 \
+ technical_staff,dc 1 \
+ technical_staff,hw 1 \
+ technical_staff,non_assets 1 \
+ technical_staff,ns 1 \
+ technical_staff,ot 1 \
+ technical_staff,published 1 \
+ technical_staff,ss 1 \
+ technical_staff,tech_contact_record 1 \
+ technical_staff,vh 1 \
+ technical_staff,vm 1 \
+ technical_manager,assets 5 \
+ technical_manager,dc 5 \
+ technical_manager,hw 5 \
+ technical_manager,non_assets 5 \
+ technical_manager,ns 5 \
+ technical_manager,ot 5 \
+ technical_manager,published 5 \
+ technical_manager,ss 5 \
+ technical_manager,tech_contact_record 5 \
+ technical_manager,vh 5 \
+ technical_manager,vm 5 \
+ technical_admin,assets 23 \
+ technical_admin,dc 23 \
+ technical_admin,hw 23 \
+ technical_admin,non_assets 23 \
+ technical_admin,ns 23 \
+ technical_admin,ot 23 \
+ technical_admin,published 23 \
+ technical_admin,ss 23 \
+ technical_admin,tech_contact_record 23 \
+ technical_admin,vh 23 \
+ technical_admin,vm 23 \
+ main_staff,admin_contact_record 1 \
+ main_staff,assets 1 \
+ main_staff,main_contact_record 1 \
+ main_staff,non_assets 1 \
+ main_staff,published 1 \
+ main_staff,tech_contact_record 1 \
+ main_manager,admin_contact_record 5 \
+ main_manager,assets 5 \
+ main_manager,main_contact_record 5 \
+ main_manager,non_assets 5 \
+ main_manager,published 5 \
+ main_manager,tech_contact_record 5 \
+ main_admin,admin_contact_record 23 \
+ main_admin,assets 23 \
+ main_admin,main_contact_record 23 \
+ main_admin,non_assets 23 \
+ main_admin,published 23 \
+ main_admin,tech_contact_record 23 ]
+ set i_rp_list [array names rp_map_arr]
+ foreach i $i_rp_list {
+ set priv_arr(${i}) $rp_map_arr(${i})
+ }
+
+ # setup initializations for privilege check
+ array set rpv_arr [list read 1 create 2 write 4 delete 8 admin 16]
+ set rpn_list [array names rpv_arr]
+
+ ns_log Notice "tcl/test/q-control-procs.tcl.60: roles_list '${roles_list}'"
+ ns_log Notice "tcl/test/q-control-procs.tcl.61: rpn_list '${rpn_list}'"
+ ns_log Notice "tcl/test/q-control-procs.tcl.61: asset_type_ids_list '${asset_type_ids_list}'"
+
+ # Case 1: A user with sysadmin rights and not customer
+ set sysowner_email [ad_system_owner]
+ set sysowner_user_id [party::get_by_email -email $sysowner_email]
+ set i [string first "@" $sysowner_email]
+ if { $i > -1 } {
+ set domain [string range $sysowner_email $i+1 end]
+ } else {
+ set domain [hf_domain_example]
+ }
+
+ # Case 2: A user registered to read package and not customer
+ set z [clock seconds]
+ set email "test${z}@${domain}"
+ array set u_site_arr [auth::create_user -first_names [join [qal_namelur] " "] -last_name [qal_namelur 1] -email $email ]
+ if { $u_site_arr(creation_status) ne "ok" } {
+ # Could not create user
+ ns_log Warning "Could not create test user u_site_arr=[array get u_site_arr]"
+ } else {
+ set site_user_id $u_site_arr(user_id)
+ permission::grant -party_id $site_user_id -object_id $instance_id -privilege read
+ }
+
+
+ # Case 3: A customer with single user
+ incr z
+ set email "test${z}@${domain}"
+ array set u_mnp_arr [auth::create_user -first_names [join [qal_namelur] " "] -last_name [qal_namelur 1] -email $email ]
+ if { $u_mnp_arr(creation_status) ne "ok" } {
+ # Could not create user
+ ns_log Warning "Could not create test user u_mnp_arr=[array get u_mnp_arr]"
+ } else {
+ set mnp_user_id $u_mnp_arr(user_id)
+ permission::grant -party_id $mnp_user_id -object_id $instance_id -privilege read
+ }
+ incr z
+ # Create customer records
+ set customer_id 3
+ foreach role $roles_list {
+ qc_user_role_add $customer_id $mnp_user_id $role_id_arr(${role}) $instance_id
+ }
+
+ # Case 4: A customer with desparate user roles
+ # Make each user one different role
+ set c4_uid_list [list ]
+ foreach role $roles_list {
+ incr z
+ set email "test${z}@${domain}"
+ set arr1_name u1_${role}_arr
+ array set $arr1_name [auth::create_user -first_names [join [qal_namelur] " "] -last_name [qal_namelur 1] -email $email ]
+ if { [lindex [array get $arr1_name creation_status] 1] ne "ok" } {
+ # Could not create user
+ ns_log Warning "Could not create test user u_${role}_arr=[array get u_${role}_arr]"
+ } else {
+ set uid [set u1_${role}_arr(user_id) ]
+ set c4ui(${role}) $uid
+ set c4urole(${uid}) $role
+ lappend c4_uid_list $uid
+ permission::grant -party_id $uid -object_id $instance_id -privilege read
+ }
+ }
+ # Create customer records
+ set customer_id 4
+ foreach role $roles_list {
+ qc_user_role_add $customer_id $c4ui(${role}) $role_id_arr(${role}) $instance_id
+ ns_log Notice "tcl/test/q-control-procs.tcl.200: added customer_id ${customer_id} user_id $uid role $role"
+ }
+
+
+ # Case 5: A customer with some random duplicates
+ set c5_uid_list [list ]
+ foreach role $roles_list {
+ incr z
+ set email "test${z}@${domain}"
+ set arrm_name m_${role}_arr
+ array set $arrm_name [auth::create_user -first_names [join [qal_namelur] " "] -last_name [qal_namelur 1] -email $email ]
+ if { [lindex [array get $arrm_name creation_status] 1] ne "ok" } {
+ # Could not create user
+ ns_log Warning "Could not create test user m_${role}_arr=[array get m_${role}_arr]"
+ } else {
+ set uid [set m_${role}_arr(user_id) ]
+ lappend c5ui_arr(${role}) $uid
+ lappend c5_uid_list $uid
+ permission::grant -party_id $uid -object_id $instance_id -privilege read
+ }
+ }
+ # Create customer records
+ set customer_id 5
+ set roles_list_len_1 [llength $roles_list]
+ incr roles_list_len_1 -1
+ # c5uwr_larr = users with role, each key contains list of user_ids assigned role.
+ foreach role $roles_list {
+ set uid $c5ui_arr(${role})
+ # make sure every role is assigned to a user
+ qc_user_role_add $customer_id $uid $role_id_arr(${role}) $instance_id
+ ns_log Notice "tcl/test/q-control-procs.tcl.230: added customer_id ${customer_id} user_id $uid role $role"
+ lappend c5uwr_larr(${uid}) $role
+ # assign a random role to same user.
+ set r [randomRange $roles_list_len_1]
+ set u_role [lindex $roles_list $r]
+ if { $u_role ne "" } {
+ ns_log Notice "tcl/test/q-control-procs.tcl.310. u_role '${u_role}'"
+ qc_user_role_add $customer_id $uid $role_id_arr(${u_role}) $instance_id
+ ns_log Notice "tcl/test/q-control-procs.tcl.238: added customer_id ${customer_id} user_id $uid role $u_role"
+ lappend c5uwr_larr(${uid}) $u_role
+ } else {
+ ns_log Warning "tcl/test/q-control-procs.tcl.316: u_role blank. r '${r}' roles_list_len_1 ${roles_list_len_1}"
+ }
+ }
+
+
+
+ # Case 1 process
+ # Loop through each subcase
+ set rp_allowed_p 1
+ set customer_id ""
+
+ foreach role $roles_list {
+ # at_id = asset_type_id
+ foreach at_id $asset_type_ids_list {
+ foreach rpn $rpn_list {
+ set customer_id [randomRange 4]
+ incr customer_id
+ set hp_allowed_p [qc_permission_p $sysowner_user_id $customer_id $at_id $rpn $instance_id]
+ # syaadmin should be 1 for all tests
+ aa_equals "C1 sysadmin ${role} ${at_id} ${rpn}" $hp_allowed_p $rp_allowed_p
+ }
+ }
+ }
+
+
+ # Case 2 process
+ # Loop through each subcase
+ set rp_allowed_p 0
+ set c 0
+ # at_id = asset_type_id
+ foreach at_id $asset_type_ids_list {
+ #check against existing customers and non existent customers.
+ incr c
+ if { $c > 5 } {
+ set customer_id ""
+ set c 1
+ }
+ foreach rpn $rpn_list {
+
+ set hp_allowed_p [qc_permission_p $site_user_id $customer_id $at_id $rpn $instance_id]
+ # site_user should be 0 for all tests except read published
+ # User has no roles.
+ if { $rpn eq "read" && $at_id eq "published" } {
+ set rp_allowed_p 1
+ } else {
+ set rp_allowed_p 0
+ }
+ aa_equals "C2 site uid:${site_user_id} customer:${customer_id} ${at_id} ${rpn}" $hp_allowed_p $rp_allowed_p
+ }
+ }
+
+
+
+
+ # Case 3 process
+ # Loop through each subcase
+ set customer_id 3
+ # at_id = asset_type_id
+ set c3_role_ids_list [qc_roles_of_user_contact_id $mnp_user_id $customer_id $instance_id]
+ ns_log Notice "tcl/test/q-control-procs.tcl.303 c3_role_ids_list '${c3_role_ids_list}'"
+ foreach at_id $asset_type_ids_list {
+ foreach rpn $rpn_list {
+ set hp_allowed_p [qc_permission_p $mnp_user_id $customer_id $at_id $rpn $instance_id]
+ # mnp_user should be 1 for all tests except delete
+ # Because user has all roles.
+ if { $rpn eq "delete" || [string match "permission*" $at_id] } {
+ set rp_allowed_p 0
+ } else {
+ set rp_allowed_p 1
+ }
+ aa_equals "C3 1customer-user:${mnp_user_id} customer:${customer_id} ${at_id} ${rpn}" $hp_allowed_p $rp_allowed_p
+ }
+ }
+
+
+
+
+ # Check each user against each asset_type_ids_list,
+ # Case 4 process
+ set customer_id 4
+ # Loop through each subcase
+ foreach c4uid $c4_uid_list {
+ # at_id = asset_type_id
+ foreach at_id $asset_type_ids_list {
+ foreach rpn $rpn_list {
+ set hp_allowed_p [qc_permission_p $c4uid $customer_id $at_id $rpn $instance_id]
+ set role $c4urole(${c4uid})
+ if { $c4ui(${role}) eq $c4uid && [expr { $rpv_arr(${rpn}) & $priv_arr(${role},${at_id}) } ] > 0 } {
+ set rp_allowed_p 1
+ } else {
+ set rp_allowed_p 0
+ }
+ # these have not been assigned to anyone
+ if { $rpn eq "delete" || [string match "permission*" $at_id] } {
+ set rp_allowed_p 0
+ }
+ # permissions defaults for all registered users with read priv.
+ if { $rpn eq "read" && $at_id eq "published" } {
+ set rp_allowed_p 1
+ }
+ # test privilege against role when c4uid = crui(role), otherwise 0
+ aa_equals "C4 1role/uid uid:${c4uid} ${role} ${at_id} ${rpn}" $hp_allowed_p $rp_allowed_p
+ }
+ }
+ }
+
+
+
+ # Case 5 process
+ set customer_id 5
+ # Loop through each subcase
+ foreach c5uid $c5_uid_list {
+ # at_id = asset_type_id
+ foreach at_id $asset_type_ids_list {
+ foreach rpn $rpn_list {
+ set hp_allowed_p [qc_permission_p $c5uid $customer_id $at_id $rpn $instance_id]
+ set rp_allowed_p 0
+ foreach role $c5uwr_larr(${c5uid}) {
+ if { [expr { $rpv_arr(${rpn}) & $priv_arr(${role},${at_id}) } ] > 0 } {
+ set rp_allowed_p 1
+ }
+ }
+ # these have not been assigned to anyone
+ if { $rpn eq "delete" || [string match "permission*" $at_id] } {
+ set rp_allowed_p 0
+ }
+ # permissions defaults for all registered users with read priv.
+ if { $rpn eq "read" && $at_id eq "published" } {
+ set rp_allowed_p 1
+ }
+ # test privilege against role when c5uid = crui(role), otherwise 0
+ aa_equals "C5 uid:${c5uid} ${role} ${at_id} ${rpn}" $hp_allowed_p $rp_allowed_p
+ }
+ }
+
+ }
+
+
+
+
+ # Case 6: Case 5 with some random role deletes, so that only one user per role, but maybe differnt user than c5..
+ set customer_id 5
+ foreach c5cuid $c5_uid_list {
+ set t_list $c5uwr_larr(${c5uid})
+ set t_len [llength $t_list]
+ while { $t_len > 1 } {
+ incr t_len -1
+ set i [randomRange $t_len]
+ set role [lindex $t_list $i]
+ qc_user_role_delete $customer_id $c5uid $role_id_arr(${role}) $instance_id
+ ns_log Notice "tcl/test/q-control-procs.tcl.255: delete customer_id ${customer_id} user_id $c5uid role $role"
+ set t_list [lreplace $t_list $i $i]
+ }
+ set c5uwr_larr(${c5uid}) $t_list
+ }
+
+
+ns_log Notice "tcl/test/q-control-procs.tcl.397"
+
+ # Case 6 process
+ set customer_id 5
+ # Loop through each subcase
+ foreach c5uid $c5_uid_list {
+ # at_id = asset_type_id
+ foreach at_id $asset_type_ids_list {
+ foreach rpn $rpn_list {
+ set hp_allowed_p [qc_permission_p $c5uid $customer_id $at_id $rpn $instance_id]
+ set rp_allowed_p 0
+ #ns_log Notice "tcl/test/q-control-procs.tcl.408 at_id $at_id rpn $rpn"
+ foreach role $c5uwr_larr(${c5uid}) {
+ if { [expr { $rpv_arr(${rpn}) & $priv_arr(${role},${at_id}) } ] > 0 } {
+ set rp_allowed_p 1
+ }
+ }
+ # these have not been assigned to anyone
+ if { $rpn eq "delete" || [string match "permission*" $at_id] } {
+ set rp_allowed_p 0
+ }
+ # permissions defaults for all registered users with read priv.
+ if { $rpn eq "read" && $at_id eq "published" } {
+ set rp_allowed_p 1
+ }
+ # test privilege against role when c5uid = crui(role), otherwise 0
+ aa_equals "C6 c5uid:${c5uid} [join $c5uwr_larr(${c5uid}) ","] ${at_id} ${rpn}" $hp_allowed_p $rp_allowed_p
+ }
+ }
+
+ }
+
+ ns_log Notice "tcl/test/q-control-procs.tcl.429 end"
+ } \
+ -teardown_code {
+ #
+ #acs_user::delete -user_id $user1_arr(user_id) -permanent
+
+ }
+ #aa_true "Test for .." $passed_p
+ #aa_equals "Test for .." $test_value $expected_value
+
+
+}
Index: openacs-4/packages/spreadsheet/tcl/test/tips-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/spreadsheet/tcl/test/tips-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/spreadsheet/tcl/test/tips-procs.tcl 2 Jan 2017 10:36:06 -0000 1.1
@@ -0,0 +1,829 @@
+ad_library {
+ Automated tests for spreadsheet qss_tips_* procedures
+ @creation-date 20161104
+}
+
+aa_register_case -cats {api smoke} qss_tips_check {
+ Test api for tips procs ie qss_tips_*
+} {
+ aa_run_with_teardown \
+ -test_code {
+ # -rollback \
+ ns_log Notice "tcl/test/tips-procs.tcl.12: test begin"
+ set instance_id [ad_conn package_id]
+ # create a scenario to test this api:
+
+
+
+ # # #
+ # table definitions
+ set flags "test"
+ set i 1
+ while { ${i} < 4 } {
+ # setup table def
+ set word_count [randomRange 10]
+ incr word_count
+ set title [qal_namelur $word_count]
+ set labelized [string tolower $title]
+ regsub -all { } $labelized {_} labelized
+ if { $labelized eq "" } {
+ incr word_count
+ set labelized [ad_generate_random_string $word_count]
+ }
+ set t_label_arr(${i}) $labelized
+ set t_name_arr(${i}) $title
+ set t_flags_arr(${i}) $flags
+ set t_trashed_p_arr(${i}) 0
+
+ set t_id_arr(${i}) [qss_tips_table_def_create $labelized $title $flags]
+ if { $t_id_arr(${i}) ne "" } {
+ set t_id_exists_p 1
+ } else {
+ set t_id_exists_p 0
+ }
+ aa_true "Test.A${i} table def. created table_id '$t_id_arr(${i})' label '${labelized}' title ${title}" $t_id_exists_p
+ set t_larr(${i}) [qss_tips_table_def_read_by_id $t_id_arr(${i})]
+ set t_i_id ""
+ set t_i_label ""
+ set t_i_name ""
+ set t_i_flags ""
+ set t_i_trashed_p ""
+ foreach {t_i_id t_i_label t_i_name t_i_flags t_i_trashed_p} $t_larr(${i}) {
+ # set vars
+ }
+ aa_equals "Test.B${i} table def. create/read id" $t_i_id $t_id_arr(${i})
+ aa_equals "Test.C${i} table def. create/read label" [string range $t_i_label 0 36] [string range $t_label_arr(${i}) 0 36]
+ set tin_max [expr { [string length $t_i_name] - 3 } ]
+ aa_equals "Test.D${i} table def. create/read name" [string range $t_i_name 0 $tin_max] [string range $t_name_arr(${i}) 0 $tin_max]
+ aa_equals "Test.E${i} table def. create/read flags" $t_i_flags $t_flags_arr(${i})
+ aa_equals "Test.F${i} table def. create/read trashed_p" $t_i_trashed_p $t_trashed_p_arr(${i})
+ if { ${i} == 1 } {
+ set success_p [qss_tips_table_def_trash $t_i_id]
+ aa_true "Test.G${i} table def. trashed ok" $success_p
+ }
+ if { ${i} == 2 } {
+ set word_count [randomRange 10]
+ incr word_count
+ set title [qal_namelur $word_count]
+ set labelized [string tolower $title]
+ regsub -all { } $labelized {_} labelized
+ if { $labelized eq "" } {
+ incr word_count
+ set labelized [ad_generate_random_string $word_count]
+ }
+ set t_label_arr(${i}) $labelized
+ set t_name_arr(${i}) $title
+ set t_flags_arr(${i}) $flags
+ set t_trashed_p_arr(${i}) 0
+
+ qss_tips_table_def_update $t_i_id label $labelized name $title flags $flags
+ set t_larr(${i}) [qss_tips_table_def_read_by_id $t_id_arr(${i})]
+ set t_i_id ""
+ set t_i_label ""
+ set t_i_name ""
+ set t_i_trashed_p ""
+ foreach {t_i_id t_i_label t_i_name t_i_flags t_i_trashed_p} $t_larr(${i}) {
+ # set vars
+ }
+ aa_equals "Test.H${i} table def. update/read label by param" [string range $t_i_label 0 36] [string range $t_label_arr(${i}) 0 36]
+ set tin_max [expr { [string length $t_i_name] - 3 } ]
+ aa_equals "Test.I${i} table def. update/read name by param" [string range $t_i_name 0 $tin_max] [string range $t_name_arr(${i}) 0 $tin_max]
+ aa_equals "Test.J${i} table def. update/read flags by param" $t_i_flags $t_flags_arr(${i})
+ aa_equals "Test.K${i} table def. update/read trashed_p by param" $t_i_trashed_p $t_trashed_p_arr(${i})
+
+ }
+ if { ${i} == 3 } {
+ set word_count [randomRange 10]
+ incr word_count
+ set title [qal_namelur $word_count]
+ set labelized [string tolower $title]
+ regsub -all { } $labelized {_} labelized
+ if { $labelized eq "" } {
+ incr word_count
+ set labelized [ad_generate_random_string $word_count]
+ }
+ set t_label_arr(${i}) $labelized
+ set t_name_arr(${i}) $title
+ set t_flags_arr(${i}) $flags
+ set t_trashed_p_arr(${i}) 0
+
+ qss_tips_table_def_update $t_i_id [list label $labelized name $title flags $flags]
+ set t_larr(${i}) [qss_tips_table_def_read_by_id $t_id_arr(${i})]
+ set t_i_id ""
+ set t_i_label ""
+ set t_i_name ""
+ set t_i_trashed_p ""
+ foreach {t_i_id t_i_label t_i_name t_i_flags t_i_trashed_p} $t_larr(${i}) {
+ # set vars
+ }
+ aa_equals "Test.L${i} table def. update/read label by list" [string range $t_i_label 0 36] [string range $t_label_arr(${i}) 0 36]
+ set tin_max [expr { [string length $t_i_name] - 3 } ]
+ aa_equals "Test.M${i} table def. update/read name by list" [string range $t_i_name 0 $tin_max] [string range $t_name_arr(${i}) 0 $tin_max]
+ aa_equals "Test.N${i} table def. update/read flags by list" $t_i_flags $t_flags_arr(${i})
+ aa_equals "Test.O${i} table def. update/read trashed_p by list" $t_i_trashed_p $t_trashed_p_arr(${i})
+ }
+
+ incr i
+ }
+ incr i -1
+ set exists_p [qss_tips_table_id_exists_q $t_i_id]
+ aa_true "Test.P${i} table def. exists_q" $exists_p
+ # we have to grab t_i_label to test because create may have modified label..
+ set table_list [qss_tips_table_def_read_by_id $t_i_id]
+ set t_i_label [lindex $table_list 1]
+ set test_t_id [qss_tips_table_id_of_label $t_i_label]
+ aa_equals "Test.Q${i} table_id_of_label" $test_t_id $t_i_id
+
+
+
+ # # #
+ # field definitions
+
+ # initializations (create table)
+ incr i
+ set word_count [randomRange 10]
+ incr word_count
+ set title [qal_namelur $word_count]
+ set labelized [string tolower $title]
+ regsub -all { } $labelized {_} labelized
+ if { $labelized eq "" } {
+ incr word_count
+ set labelized [ad_generate_random_string $word_count]
+ }
+ set t_label_arr(${i}) $labelized
+ set t_name_arr(${i}) $title
+ set t_flags_arr(${i}) $flags
+ set t_trashed_p_arr(${i}) 0
+ set t_id_arr(${i}) [qss_tips_table_def_create $labelized $title $flags]
+ set j 0
+ set field_defs_by_ones_list [list ]
+ foreach field_type [list txt vc1k nbr] {
+ incr j
+ set name [qal_namelur 2]
+ regsub -all { } [string tolower $name] {_} label
+ set f_name_arr($j) $name
+ set f_label_arr($j) $label
+ set f_field_type_arr($j) $field_type
+ set f_tdt_data_type_arr($j) ""
+ set f_default_value_arr($j) ""
+ # qss_tips_field_def_create
+ set f_def_id [qss_tips_field_def_create table_id $t_id_arr(${i}) label $label name $name field_type $field_type]
+ if { [qf_is_natural_number $f_def_id] } {
+ set success_p 1
+ } else {
+ set success_p 0
+ }
+ aa_true "Test.R${i}-${j} field_def created label ${label} of type ${field_type} for table_id '$t_id_arr(${i})'" $success_p
+ # qss_tips_field_def_read
+ set f_def1_list [qss_tips_field_def_read $t_id_arr(${i}) "" $f_def_id]
+ set f_def2_list [qss_tips_field_def_read $t_id_arr(${i}) $label]
+ if { $f_def1_list eq $f_def2_list } {
+ set success_p 1
+ } else {
+ set success_p 0
+ }
+ aa_true "Test.S${i}-${j} field_def read via label ${label} VS. via field_id matches" $success_p
+ lappend field_defs_by_ones_list $f_def_id
+ }
+ # field_id,label,name,default_val,tdt_data_type,field_type or empty list if not found
+ set f_def_lists [qss_tips_field_def_read $t_id_arr(${i}) ]
+ set f_def_lists_len [llength $f_def_lists]
+ set field_defs_by_ones_list_len [llength $field_defs_by_ones_list]
+ aa_equals "Test.T${i}. qss_tips_field_def_read. Quantity of all same as adding each one" $f_def_lists_len $field_defs_by_ones_list_len
+ foreach f_list $f_def_lists {
+ set f_def_id_ck [lindex $f_list 0]
+ if { $f_def_id_ck in $field_defs_by_ones_list } {
+ set success_p 1
+ } else {
+ set success_p 0
+ }
+ aa_true "Test.U${i} field_def_id '${f_def_id_ck}' from single read in bulk read also" $success_p
+ }
+ foreach f_list $f_def_lists {
+ set f_def_id_i [lindex $f_list 0]
+ set f_field_type [lindex $f_list 5]
+ set name_new $f_field_type
+ append name_new "_test"
+ set success_p [qss_tips_field_def_update $t_id_arr(${i}) field_id $f_def_id_i name_new $name_new]
+ aa_true "Test.V${i} field_def_id '${f_def_id_i}' name change to '${name_new}'" $success_p
+ set f2_list [qss_tips_field_def_read $t_id_arr(${i}) "" $f_def_id_i ]
+ set f2_name [lindex [lindex $f2_list 0] 2]
+ if { $f2_name eq $name_new } {
+ set success_p 1
+ } else {
+ set success_p 0
+ }
+ aa_true "Test.W${i} field_def_id '${f_def_id_i}' confirmed name changed to '${name_new}'" $success_p
+
+ set label_new $f_field_type
+ append label_new "_" $f_def_id_i
+ set success_p [qss_tips_field_def_update $t_id_arr(${i}) field_id $f_def_id_i label_new $label_new]
+ aa_true "Test.X${i} field_def_id '${f_def_id_i}' label change to '${label_new}'" $success_p
+ set f2_list [qss_tips_field_def_read $t_id_arr(${i}) $label_new ]
+ set f2_label [lindex [lindex $f2_list 0] 1]
+ if { $f2_label eq $label_new } {
+ set success_p 1
+ } else {
+ set success_p 0
+ }
+ aa_true "Test.Y${i} field_def_id '${f_def_id_i}' confirmed label changed to '${label_new}'" $success_p
+ }
+ foreach field_type [list txt vc1k nbr] {
+ # qss_tips_field_def_create some new ones
+ set label $field_type
+ set name [string toupper $field_type]
+ set f_def_id [qss_tips_field_def_create table_id $t_id_arr(${i}) label $label name $name field_type $field_type]
+ # qss_tips_field_def_read to confirm
+ set f_def_list [qss_tips_field_def_read $t_id_arr(${i}) "" $f_def_id]
+ set f_def1_list [lindex $f_def_list 0]
+ foreach {f_def_id2 label2 name2 default_val2 tdt_data_type2 field_type2} $f_def1_list {
+ # loading vars
+ }
+ aa_equals "Test.Z${i}. qss_tips_field_def_create confirm id" $f_def_id2 $f_def_id
+ aa_equals "Test.AA${i}. qss_tips_field_def_create confirm label" $label2 $label
+ aa_equals "Test.AB${i}. qss_tips_field_def_create confirm name" $name2 $name
+ aa_equals "Test.AC${i}. qss_tips_field_def_create confirm default_val" $default_val2 ""
+ aa_equals "Test.AD${i}. qss_tips_field_def_create confirm tdt_data_type" $tdt_data_type2 ""
+ aa_equals "Test.AE${i}. qss_tips_field_def_create confirm field_type" $field_type2 $field_type
+ }
+ # qss_tips_field_def_trash the old ones
+ set field_id [lindex $field_defs_by_ones_list 0]
+ set field_ids_list [lrange $field_defs_by_ones_list 1 end]
+ set success1_p [qss_tips_field_def_trash $field_id $t_id_arr(${i})]
+ aa_true "Test.AF${i}. qss_tips_field_def_trash one id '${field_id}'" $success1_p
+ set success2_p [qss_tips_field_def_trash $field_ids_list $t_id_arr(${i})]
+ aa_true "Test.AG${i}. qss_tips_field_def_trash list of ids '${field_ids_list}'" $success2_p
+ # qss_tips_field_def_read to confirm
+ set defs_lists [qss_tips_field_def_read $t_id_arr(${i}) ]
+ set success_p 1
+ foreach def_list $defs_lists {
+ set id [lindex $def_list 0]
+ if { $id in $field_defs_by_ones_list } {
+ set success_p 0
+ }
+ }
+ aa_true "Test.AH${i}. qss_tips_field_def_trash confirm old ones deleted" $success_p
+
+ # qss_tips_field_defs_maps_set (Ignore, because this is intrinsic to other proc operations)
+ # qss_tips_field_id_name_list
+ # qss_tips_field_label_name_list
+
+
+ # initializations (create table)
+ incr i
+ set unique [clock seconds]
+ set title "Table ${unique}"
+ set labelized [string tolower $title]
+ regsub -all { } $labelized {_} labelized
+ set t_label_arr(${i}) $labelized
+ set t_name_arr(${i}) $title
+ set t_flags_arr(${i}) $flags
+ set t_trashed_p_arr(${i}) 0
+ set t_id_arr(${i}) [qss_tips_table_def_create $labelized $title $flags]
+ if { $t_id_arr(${i}) > 0 } {
+ set success_p 1
+ } else {
+ set success_p 0
+ }
+ aa_true "Test.AI${i}. qss_tips_table_def_create for '${labelized}'" $success_p
+ set j 0
+ set field_defs_by_ones_list [list ]
+ foreach field_type [list txt vc1k nbr] {
+ incr j
+ set name "Data for "
+ append name [string toupper $field_type]
+ set label [string tolower $name]
+ regsub -all -- { } $label {_} label
+ set f_name_arr($j) $name
+ set f_label_arr($j) $label
+ set f_field_type_arr($j) $field_type
+ set f_tdt_data_type_arr($j) ""
+ set f_default_value_arr($j) ""
+ # qss_tips_field_def_create
+ set f_def_id [qss_tips_field_def_create table_id $t_id_arr(${i}) label $label name $name field_type $field_type]
+
+ if { [qf_is_natural_number $f_def_id] } {
+ set success_p 1
+ set field_id_of_label_arr(${label}) $f_def_id
+ } else {
+ set success_p 0
+ }
+ aa_true "Test.AJ${i}-${j} field_def created label ${label} of type ${field_type} for table_id '$t_id_arr(${i})'" $success_p
+ # qss_tips_field_def_read
+ lappend field_defs_by_ones_list $f_def_id
+ }
+ # field_id,label,name,default_val,tdt_data_type,field_type or empty list if not found
+
+ # # #
+ # data rows
+
+ set label_value_list [list ]
+ set field_label_list [list ]
+
+ # make some data
+ for {set j 1} {$j < 4} {incr j} {
+ switch -exact $f_field_type_arr($j) {
+ txt {
+ set value [qal_namelur [randomRange 20]]
+ }
+ vc1k {
+ set value [string range [qal_namelur [randomRange 10]] 0 38]
+ # next value used in a later test that builds on this row.
+ set row1_vc1k $value
+ set row1_vc1k_idx $j
+ set h_vc1k_at_r_arr(1) $value
+ }
+ nbr {
+ set value [clock microseconds]
+ }
+ }
+ set f_value_arr($j) $value
+ set label $f_label_arr($j)
+ set rowck_arr(1,${label}) $value
+ lappend label_value_list $label $value
+ lappend field_label_list $label
+ }
+ # qss_tips_row_create
+ set r 1
+ set f_row_id [qss_tips_row_create $t_id_arr(${i}) $label_value_list]
+ if { $f_row_id ne "" } {
+ set success_p 1
+ set f_row_id_arr(${r}) $f_row_id
+ # first and last occurrance are determined by this ordered list of mapped ids. 0 is first..
+ lappend f_row_nbr_larr(${f_row_id}) $r
+ lappend data_row_id_list $f_row_id
+ set data_row_id_list [list $f_row_id]
+ } else {
+ set success_p 0
+ }
+ set f_row_id_arr($r) $f_row_id
+ set label_value_larr($r) $label_value_list
+
+ aa_true "Test.AP0${i} row ${r} qss_tips_row_create row_id '${f_row_id}' table_id '$t_id_arr(${i})' data '$label_value_larr(${r})'" $success_p
+ aa_true "Test.AK${i} row created for table_id '$t_id_arr(${i})'" $success_p
+ # qss_tips_row_id_exists_q
+ set f_row_id_ck [qss_tips_row_id_exists_q $f_row_id $t_id_arr(${i})]
+ aa_true "Test.AL${i} qss_tips_row_id_exists_q for row_id '${f_row_id}' table_id '$t_id_arr(${i})'" $f_row_id_ck
+ # qss_tips_row_read
+ aa_log "Test.AM${i} qss_tips_row_create fed to row_id '${f_row_id}': '${label_value_list}'"
+ set row_list [qss_tips_row_read $t_id_arr(${i}) ${f_row_id}]
+ aa_log "Test.AN${i} qss_tips_row_read results: '${row_list}'"
+ foreach {k v} $row_list {
+ set row1ck_arr(${k}) $v
+ }
+ ns_log Notice "test/tips-procs.tcl.357. field_label_list '${field_label_list}'"
+ foreach label $field_label_list {
+ if { $rowck_arr(1,${label}) eq $row1ck_arr(${label}) } {
+ set success_p 1
+ } else {
+ set success_p 0
+ }
+ aa_true "Test.AO${i} qss_tips_row_read for table_id '$t_id_arr(${i})' row_id '${f_row_id}' label '${label}'" $success_p
+ }
+
+ # make some more data rows
+ set r_count_max 39
+ # set the value for vc1k to unique values, except add a duplicate or more to test some api features
+ set duplicate_count [randomRange 3]
+ # Add an extra duplicate, because there is a random chance a duplicate row is deleted later in the testing
+ incr duplicate_count 2
+ set unique_count [expr { $r_count_max - $duplicate_count } ]
+ set r 2
+ set vc1k_val_list [list $row1_vc1k]
+ while { $r < $unique_count } {
+ set value [string range [qal_namelur [randomRange 10]] [randomRange 10] 38]
+ ns_log Notice "test/tips-procs.tcl appended vc1k_val_list with element value '${value}"
+ aa_log "i $i r $r Appending vc1k_val_list with element value '${value}'"
+ lappend vc1k_val_list $value
+ set vc1k_val_list [qf_uniques_of $vc1k_val_list]
+ set r [llength $vc1k_val_list]
+ }
+
+ # chose one value to duplicate
+ set dup_idx [randomRange $unique_count]
+ set duplicate_val [lindex $vc1k_val_list $dup_idx]
+ set vc1k_val_list [concat $vc1k_val_list [lrepeat $duplicate_count $duplicate_val]]
+ set vc1k_val_list [acc_fin::shuffle_list $vc1k_val_list]
+
+ for {set r 2} {$r <= $r_count_max } {incr r} {
+ set label_value_larr(${r}) [list ]
+ for {set j 1} {$j < 4} {incr j} {
+ switch -exact $f_field_type_arr($j) {
+ txt {
+ set value [qal_namelur [randomRange 20]]
+ }
+ vc1k {
+ # set value [string range [qal_namelu [randomRange 10]] 0 38]
+ # pre calculated for testing
+ set value [lindex $vc1k_val_list $r]
+ set h_vc1k_at_r_arr(${r}) $value
+ }
+ nbr {
+ set value [clock microseconds]
+ }
+ }
+ set label $f_label_arr($j)
+ # retained values by RC reference:
+ set rowck_arr(${r},${label}) $value
+ lappend label_value_larr(${r}) $label $value
+ }
+ # qss_tips_row_create
+ set row_id_new [qss_tips_row_create $t_id_arr(${i}) $label_value_larr(${r})]
+ if { $row_id_new ne "" } {
+ set success_p [qss_tips_row_id_exists_q $row_id_new $t_id_arr(${i})]
+ if { $success_p } {
+ set f_row_id_arr(${r}) $row_id_new
+ # first and last occurrance are determined by this ordered list of mapped ids. 0 is first..
+ lappend f_row_nbr_larr(${row_id_new}) $r
+ lappend data_row_id_list $row_id_new
+ }
+ } else {
+ set success_p 0
+ }
+ aa_true "Test.AP${i} row ${r} qss_tips_row_create row_id '${row_id_new}' table_id '$t_id_arr(${i})' data '$label_value_larr(${r})'" $success_p
+
+ }
+
+ # # # check a row from nonduplicates, and check duplicate cases.
+ set value_ck $duplicate_val
+ while { $value_ck eq $duplicate_val } {
+ set unique_idx [randomRange 38]
+ set value_ck [lindex $vc1k_val_list $unique_idx]
+ }
+
+ set val_ck_list [list $value_ck $duplicate_val]
+ set val_dup_ck_list [list 0 1]
+ set vdcli -1
+ set vc1k_label [lindex $field_label_list 1]
+ set test_row_id_list [list ]
+ aa_log "val_ck_list '${val_ck_list}'"
+ foreach v $val_ck_list {
+ incr vdcli
+
+ if { $v eq $duplicate_val } {
+ set is_duplicate_p 1
+ } else {
+ set is_duplicate_p 0
+ }
+
+ aa_log "\r\r
+
+BEGIN TEST LOOP for value '${v}'"
+ aa_equals "TEST.AQ0-${i} v is '${v}' is_duplicate_p '${is_duplicate_p}'" $is_duplicate_p [lindex $val_dup_ck_list $vdcli]
+
+ for {set if_multiple -1} {$if_multiple < 2} {incr if_multiple} {
+ # have to use the original label value in the search.
+
+ if { [info exists row_id] } {
+ unset row_id
+ }
+ set row_label_value_list [qss_tips_row_of_table_label_value $t_id_arr(${i}) [list $vc1k_label $v] $if_multiple row_id]
+
+ aa_log "Test.AQ${i}.row_id '${row_id}' of qss_tips_row_of_table_label_value table_id '$t_id_arr(${i})' if_multiple '${if_multiple}' row_label_value_list '${row_label_value_list}'"
+ if { $row_id in $data_row_id_list } {
+ set valid_row_id_p 1
+ lappend tested_row_id_list $row_id
+ } else {
+ set valid_row_id_p 0
+ }
+ set row_label_value_list_len [llength $row_label_value_list]
+ if { $row_label_value_list_len > 0 } {
+ set data_row_exists_p 1
+ set expect_row_id_p 1
+ } else {
+ set data_row_exists_p 0
+ set expect_row_id_p 0
+ }
+ if { $valid_row_id_p } {
+
+ set r_indexes_list [lsearch -all -exact $vc1k_val_list $v]
+ #aa_log "f_row_nbr_larr(${row_id}) '$f_row_nbr_larr(${row_id})'"
+ aa_log "r_indexes_list '${r_indexes_list}' vc1k_val_list '${vc1k_val_list}'"
+
+ set data_row_id_list_len [llength $r_indexes_list]
+ } else {
+ set data_row_id_list_len 0
+ }
+ if { $data_row_id_list_len > 1 } {
+ set multiple_rows_match_p 1
+ } else {
+ set multiple_rows_match_p 0
+ }
+
+ if { $multiple_rows_match_p && $if_multiple eq "-1" } {
+ set expect_row_id_p 0
+ }
+ aa_equals "Test.AR${i}.if_multiple '${if_multiple}' multiple_rows_match_p '${multiple_rows_match_p}' qss_tips_row_of_table_label_value returns a row_id '${row_id}' in row_ids of dataset or no row as expected." $valid_row_id_p $expect_row_id_p
+ # check each value for expected value
+ for {set j 1} {$j < 4} {incr j} {
+ set label $f_label_arr($j)
+
+ # following doesn't work for if_multiple = -1, because no rows are returned.
+ # if dict fails, qss_tips_row_of_table_value failed to return an expected field
+ if { [llength $row_label_value_list] > 0 } {
+ set vx [dict get $row_label_value_list $label]
+ } else {
+ set vx ""
+ }
+
+ # mapping of row_id and r
+ #set f_row_id_arr(${r}) $row_id
+ #lappend f_row_nbr_larr(${row_id_new}) $r
+ aa_log "row_id '$row_id' "
+ if { $is_duplicate_p } {
+ # row_id depends on if_multiple and row
+ switch -exact -- $if_multiple {
+ -1 {
+ # does not return anything when if_multiple = -1
+ set row_nbr ""
+ set ck_row_id ""
+ set v_ck ""
+
+ }
+ 0 {
+ set row_nbr [lindex $f_row_nbr_larr(${row_id}) 0]
+ set ck_row_id $f_row_id_arr(${row_nbr})
+ set v_ck $rowck_arr(${row_nbr},${label})
+ }
+ 1 {
+ set row_nbr [lindex $f_row_nbr_larr(${row_id}) end]
+ set ck_row_id $f_row_id_arr(${row_nbr})
+ set v_ck $rowck_arr(${row_nbr},${label})
+ }
+ default {
+ ns_log Warning "spreadsheet/tcl/test/tips-procs.tcl.535: This should not happen"
+ }
+ }
+
+ } else {
+ if { $valid_row_id_p } {
+ # value depends on row_id only
+ set row_nbr [lindex $f_row_nbr_larr(${row_id}) 0]
+ set ck_row_id $f_row_id_arr(${row_nbr})
+ set v_ck $rowck_arr(${row_nbr},${label})
+ } else {
+ set row_nbr ""
+ set ck_row_id ""
+ set v_ck ""
+ }
+ }
+ aa_equals "Test.AS${i} qss_tips_row_of_table_label_value for table_id '$t_id_arr(${i})' vc1k_label '${vc1k_label}' if_mupltiple '${if_multiple}' row_id check" $row_id $ck_row_id
+ aa_equals "Test.AT${i} qss_tips_row_of_table_label_value for table_id '$t_id_arr(${i})' vc1k_label '${vc1k_label}' if_mupltiple '${if_multiple}' label '${label}' value '${v_ck}'" $vx $v_ck
+
+ }
+ }
+ # back to context of row loop only
+
+ # if row_id exists and expected, perform some more tests
+ set ck_update_label_val_list [list ]
+ if { $ck_row_id eq $row_id && $row_id ne "" } {
+ set j_list [list ]
+ # for each label type, check a case. Shuffle list for diagnostics.
+ for {set j 1} {$j < 4} {incr j} {
+ lappend j_list $j
+ }
+ set j_list [acc_fin::shuffle_list $j_list]
+ ns_log Notice "test/tips-procs.tcl.575: shuffled j_list '${j_list}'"
+ foreach j $j_list {
+ switch -exact $f_field_type_arr($j) {
+ txt {
+ set value [qal_namelur [randomRange 20]]
+ }
+ vc1k {
+ # set value [string range [qal_namelu [randomRange 10]] 0 38]
+ # pre calculated for testing
+ set value [lindex $vc1k_val_list $r]
+ }
+ nbr {
+ set value [clock microseconds]
+ }
+ }
+ set label $f_label_arr($j)
+ lappend ck_update_label_val_list $label $value
+ }
+
+ # qss_tips_row_update
+ set success_p [qss_tips_row_update $t_id_arr(${i}) $row_id $ck_update_label_val_list ]
+ aa_true "Test.BA${i} qss_tips_row_update table_id '$t_id_arr(${i})' row_id '${row_id}' update_label_val_list '${ck_update_label_val_list}' success_p" $success_p
+
+ # qss_tips_rows_read
+ set ck2_update_label_val_list [qss_tips_row_read $t_id_arr(${i}) $row_id]
+ # for each label type, check a case
+ set j_list [acc_fin::shuffle_list $j_list]
+ ns_log Notice "test/tips-procs.tcl.601: shuffled j_list '${j_list}'"
+ foreach j $j_list {
+ set label $f_label_arr($j)
+ set v_ck [dict get $ck_update_label_val_list $label]
+ if { [llength $ck2_update_label_val_list] > 0 } {
+ # following doesn't work if no rows are returned.
+ # if dict fails, qss_tips_row_of_table_value failed to return an expected field
+ set v [dict get $ck2_update_label_val_list $label]
+ set label_exists_p 1
+ } else {
+ set v ""
+ set label_exists_p 0
+ }
+ aa_true "Test.BB${i}. j '${j}' label '${label}' exists" $label_exists_p
+ aa_equals "Test.BC${i} j '${j}' check label '${label}'s value" $v $v_ck
+ }
+
+ # qss_tips_row_trash
+ set success_p [qss_tips_row_trash $t_id_arr(${i}) $row_id]
+ aa_true "Test.BD${i} qss_tips_row_trash table_id '$t_id_arr(${i})' row_id '${row_id}' success_p" $success_p
+
+ # qss_tips_row_id_exists_q
+ set exists_p [qss_tips_row_id_exists_q $row_id $t_id_arr(${i})]
+ if { $exists_p } {
+ set not_exists_p 0
+ } else {
+ set not_exists_p 1
+ }
+ aa_true "Test.BE${i} qss_tips_row_trash table_id '$t_id_arr(${i})' row_id '${row_id}' not_exists_p" $not_exists_p
+
+
+ }
+ }
+ set tested_row_id_list [qf_uniques_of $tested_row_id_list]
+
+
+
+
+ # # #
+ # cells
+ # $rowck_arr(r,$label) returns initial cell value
+ # $label_value_larr(r) returns label_value_list for row
+ # $f_row_id_arr(r) returns row_id for row
+ # $f_row_nbr_larr(r) returns row number(s) for row_id
+ # data_row_id_list is a list of all row_id
+ # tested_row_id_list is a list of row_ids used in prior tests (ie don't reuse)
+ # $field_id_of_label_arr(label)
+ # $t_label_arr(${i}) is table label for case i
+ # $h_vc1k_at_r_arr(r) is value of vc1k field for row r
+ # choose an untested row_id
+ # $row1_vc1k_idx value of loop index j for vc1k label
+ set test_idx [randomRange $data_row_id_list_len]
+ set test_row_id [lindex $data_row_id_list $test_idx]
+ while { $test_row_id in $tested_row_id_list } {
+ set test_idx [randomRange $data_row_id_list_len]
+ set test_row_id [lindex $data_row_id_list $test_idx]
+ }
+ lappend tested_row_id_list $test_row_id
+ aa_log "tested_row_id_list '${tested_row_id_list}'"
+ set r [lindex $f_row_nbr_larr(${test_row_id}) 0]
+ set vc1k_search_val $h_vc1k_at_r_arr(${r})
+ aa_log "row_id '${test_row_id}' r '$r' vc1k_search_val '${vc1k_search_val}'"
+ set okay_to_v1ck_search_p 1
+ # test for each data type, ie cell in the row
+ foreach j $j_list {
+ set label $f_label_arr($j)
+ set field_id $field_id_of_label_arr(${label})
+
+ # qss_tips_cell_read
+ set val_case1 [qss_tips_cell_read $t_label_arr(${i}) [list $f_label_arr(${row1_vc1k_idx}) $vc1k_search_val] $label 1 returned_row_id ]
+ if { $okay_to_v1ck_search_p } {
+ if { $returned_row_id eq $test_row_id } {
+ aa_equals "Test.CA${i} j '${j}' check qss_tips_cell_read label label '${label}'s value by ref '$f_label_arr(${row1_vc1k_idx})' vc1k_search_val '${vc1k_search_val}'" $val_case1 $rowck_arr(${r},${label})
+ } else {
+ aa_log "Test.CA not possible since vc1k field appears to have duplciates."
+ }
+ } else {
+ aa_log "Test.CA not possible since vc1k field trashed for this row."
+ }
+
+ # qss_tips_cell_read_by_id
+ set value_by_id [qss_tips_cell_read_by_id $t_id_arr(${i}) $test_row_id $field_id]
+ aa_equals "Test.CB${i} j '${j}' check qss_tips_cell_read_by_id id '${field_id}' label '${label}'s value" $value_by_id $rowck_arr(${r},${label})
+
+ # qss_tips_cell_update
+ # create a new value of same type.
+ switch -exact $f_field_type_arr($j) {
+ txt {
+ set value [qal_namelur [randomRange 20]]
+ }
+ vc1k {
+ set value_len [randomRange 20]
+ set value [ad_generate_random_string $value_len]
+
+ }
+ nbr {
+ set value [clock microseconds]
+ }
+ }
+
+ qss_tips_cell_update $t_id_arr(${i}) $test_row_id $field_id $value
+ set rowck_arr(${r},${label}) $value
+ #qss_tips_cell_read_by_id to confirm
+
+ #so for the vc1k test field (and subsequent cell tests, update vc1k_search_val
+ # to new value
+ if { $f_label_arr(${row1_vc1k_idx}) eq $label } {
+ # new vc1k value
+ aa_log "Changing vc1k_search_value to '${value}', since $label is of type vc1k."
+ set vc1k_search_val $value
+ }
+
+
+ set value_by_id_ck [qss_tips_cell_read_by_id $t_id_arr(${i}) $test_row_id $field_id]
+ aa_equals "Test.CC${i} j '${j}' check qss_tips_cell_update using qss_tips_cell_read_by_id field_id '${field_id}' label '${label}'s value" $value $value_by_id_ck
+ set val_case1 [qss_tips_cell_read $t_label_arr(${i}) [list $f_label_arr(${row1_vc1k_idx}) $vc1k_search_val] $label 1 returned_row_id]
+ if { $okay_to_v1ck_search_p } {
+ if { $returned_row_id eq $test_row_id } {
+ aa_equals "Test.CC2${i} j '${j}' check qss_tips_cell_read label '${label}'s value by ref '$f_label_arr(${row1_vc1k_idx})' ${vc1k_search_val}" $val_case1 $rowck_arr(${r},${label})
+ } else {
+ aa_log "Test.CC2 not possible since vc1k field appears to have duplciates."
+ }
+ } else {
+ aa_log "Test.CC2 not possible since vc1k field trashed for this row."
+ }
+
+
+
+ # qss_tips_cell_trash
+ set cell_trashed_p [qss_tips_cell_trash $t_id_arr(${i}) $test_row_id $field_id]
+ aa_true "Test.CD${i} j '${j}' check qss_tips_cell_trash feedback succeeded" $cell_trashed_p
+ if { $j eq $row1_vc1k_idx } {
+ # update search value for this cell to empty cell
+ set vc1k_search_val ""
+ # But this won't work for many of the cases, because there are likely other empty cell cases.
+ # so set a flag to skip these searches by label.
+ set okay_to_v1ck_search_p 0
+ }
+ #qss_tips_cell_read_by_id to confirm
+ set value_by_id_ck [qss_tips_cell_read_by_id $t_id_arr(${i}) $test_row_id $field_id]
+ aa_equals "Test.CE${i} j '${j}' check qss_tips_cell_read_by_id id '${id}' label '${label}'s value" $value_by_id_ck ""
+
+ # qss_tips_cell_trash a trashed
+ set cell_trashed_p [qss_tips_cell_trash $t_id_arr(${i}) $test_row_id $field_id]
+ if { $cell_trashed_p } {
+ set cell_trashed_p 0
+ } else {
+ set cell_trashed_p 1
+ }
+ aa_true "Test.CF${i} j '${j}' check qss_tips_cell_trash feedback failed" $cell_trashed_p
+
+ }
+
+
+ # table read, compare to existing
+ # qss_tips_table_read
+ # Let's not overcomplicate this.
+ # Compare qss_tips_table_read to qss_tips_table_read_as_array
+ set table1_lists [qss_tips_table_read $t_label_arr(${i}) "" "" "row_id"]
+
+ # table read as array
+ qss_tips_table_read_as_array table2_arr $t_label_arr(${i})
+ # qss_tips_table_read_as_array
+
+ # compare table1 to table2
+ # first, convert table2 to table1 format.
+ # table2_arr(row_id,field_label)
+ set table_fields_list [lindex $table1_lists 0]
+ aa_log "table_fields_list '${table_fields_list}'"
+ # We added row_id to the end of table1, but we take it off here, for comparisons
+ set table_fields_list [lrange $table_fields_list 0 end-1]
+ set table_fields_list_len [llength $table_fields_list]
+ # We added row_id to table1_lists, so need to remove it from expected behavior
+ set table1_wo_labels_list [lrange $table1_lists 1 end]
+
+ set table_labels_list $table2_arr(labels)
+ set table_labels_list_len [llength $table_labels_list]
+ aa_equals "Test.DA${i} qss_table_read label count '${table_fields_list_len}'" $table_fields_list_len $table_labels_list_len
+ set diff_labels_list [set_difference $table_labels_list $table_fields_list]
+ aa_equals "Test.DB${i} set_difference table_fields table_labels" $diff_labels_list ""
+
+ set table1_wo_labels_list_len [llength $table1_wo_labels_list]
+ if { $table1_wo_labels_list_len > 0 } {
+ set table_read_returns_rows_p 1
+ } else {
+ set table_read_returns_rows_p 0
+ }
+ aa_true "Test.DC${i} qss_tips_table_read returns rows" $table_read_returns_rows_p
+ aa_log "test.DD${i} table1_lists '${table1_lists}'"
+ aa_log "test.DD${i} array names table2_arr '[array names table2_arr]'"
+ # table_fields_list is ordered
+
+ foreach row_list $table1_wo_labels_list {
+ set t1_c 0
+ set row_id [lindex $row_list end]
+ aa_log "table1 row_list '${row_list}'"
+ foreach label $table_fields_list {
+ aa_log "table1 label '[lindex $table_fields_list $t1_c]'"
+ set t1_val [lindex $row_list $t1_c]
+ set t2_val $table2_arr(${row_id},${label})
+ aa_equals "test.DE${i} table values same for row_id '${row_id}' label '${label}' t2_val '${t2_val}'" $t1_val $t2_val
+ incr t1_c
+ }
+ }
+
+
+
+ ns_log Notice "tcl/test/q-control-procs.tcl.429 test end"
+ } \
+ -teardown_code {
+
+ }
+ #aa_true "Test for .." $passed_p
+ #aa_equals "Test for .." $test_value $expected_value
+
+
+}
Index: openacs-4/packages/spreadsheet/www/test.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/spreadsheet/www/test.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/spreadsheet/www/test.adp 2 Jan 2017 10:36:06 -0000 1.1
@@ -0,0 +1,5 @@
+
+ @title;noquote@
+ @context;noquote@
+
+@content;noquote@
Index: openacs-4/packages/spreadsheet/www/test.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/spreadsheet/www/test.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/spreadsheet/www/test.tcl 2 Jan 2017 10:36:06 -0000 1.1
@@ -0,0 +1,46 @@
+set title TEST
+
+set context [list ]
+
+# oacs-dev=# select table_id,label,id from qss_tips_field_defs where id in ('10769','10767','10768');
+# table_id | label | id
+# ----------+---------------+-------
+# 10766 | data_for_txt | 10767
+# 10766 | data_for_vc1k | 10768
+# 10766 | data_for_nbr | 10769
+# (3 rows)
+
+# instance_id | table_id | row_id | trashed_p | trashed_by | trashed_dt | created | user_id | field_id | f_vc1k | f_nbr | f_txt
+#-------------+----------+--------+-----------+------------+------------+-------------------------------+---------+----------+-----------------------------+------------------+---------------------------------------------------------------------------------------------------------
+# 147 | 10766 | 10807 | 0 | | | 2016-12-15 15:20:48.570363-05 | 689 | 10769 | | 1481833248569588 |
+# 147 | 10766 | 10807 | 0 | | | 2016-12-15 15:20:48.570363-05 | 689 | 10768 | uranoonen CBrramsotes CBlag | |
+# 147 | 10766 | 10807 | 0 | | | 2016-12-15 15:20:48.570363-05 | 689 | 10767 | | | D.s D.f D.nadgadralat D.l D.fayhad D.n D.klytat D.noloshomat D.tef D.f D.gonehonyd D.nyeles D.msyih D.s
+#(3 rows)
+
+
+set user_id [ad_conn user_id]
+set instance_id [ad_conn package_id]
+set instance_id 147
+#qc_pkg_admin_required
+#set i 5
+#set j 1
+#set field_id 10768
+#set label "data_for_vc1k"
+
+#set test_row_id 10807
+#set t_id_arr(${i}) 10766
+#set vc1k_search_val "uranoonen CBrramsotes CBlag"
+
+#set t_label_arr(${i}) "table_1481833247"
+
+#set val_case1 [qss_tips_cell_read $t_label_arr(${i}) [list "data_for_vc1k" $vc1k_search_val] $label]
+
+#set value_by_id [qss_tips_cell_read_by_id $t_id_arr(${i}) $test_row_id $field_id]
+
+#set content "qss_tips_cell_read $t_label_arr(${i}) [list "data_for_vc1k" $vc1k_search_val] $label
+#returns: '${val_case1}'
+#qss_tips_cell_read_by_id $t_id_arr(${i}) $test_row_id $field_id
+#returns: '${value_by_id}'"
+set a [list 3 56 3453]
+set b [list 3453 56 7 15]
+set content "diff [set_difference $b $a]"
Index: openacs-4/packages/spreadsheet/www/doc/index.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/spreadsheet/www/doc/index.adp,v
diff -u -r1.1 -r1.2
--- openacs-4/packages/spreadsheet/www/doc/index.adp 14 Nov 2014 18:36:34 -0000 1.1
+++ openacs-4/packages/spreadsheet/www/doc/index.adp 2 Jan 2017 10:36:06 -0000 1.2
@@ -32,13 +32,13 @@
po box 20, Marylhurst, OR 97036-0020 usa
email: tekbasse@yahoo.com
-Finance Package is open source and published under the GNU General Public License,
+Spreadsheet Package is open source and published under the GNU General Public License,
consistent with the OpenACS system license: http://www.gnu.org/licenses/gpl.html
-A local copy is available at accounts-finance/www/doc/LICENSE.html
+A local copy is available at spreadsheet/www/doc/LICENSE.html
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
+ the Free Software Foundation, either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,