Index: openacs-4/packages/q-forms/INSTALL.TXT
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/q-forms/INSTALL.TXT,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/q-forms/INSTALL.TXT 14 Nov 2014 18:27:52 -0000 1.1
@@ -0,0 +1,64 @@
+Q-FORMS Installation Instructions
+
+To install in an OpenACS system, follow the standard practices for
+downloading, uncompressing, and installing a local copy of this package.
+
+Detailed instructions follow.
+
+Download Q-Forms
+
+The easiest way is to go to https://github.com/tekbasse/q-forms
+and click on the ZIP button on the left side.
+
+# From shell, that would be something like:
+
+wget https://github.com/tekbasse/q-forms/archive/master.zip
+
+# if wget isn't available locally, try fetch or curl.
+
+Uncompress Q-Forms
+
+# Once downloaded, unzip the file with 'unzip'.
+# That might have to be grabbed from freebsd ports.
+
+unzip master.zip
+
+# Then rename the directory:
+
+mv q-forms-master q-forms
+
+# move the directory to the openacs/packages/ directory
+
+mv q-forms your-openacs-4/packages/.
+
+# change to the openacs-4/packages directory
+
+cd your-openacs-4/packages
+
+# changes permissions to match other packages
+# replace user_name and user_group with your local ones. Sometimes they're openacs:openacs, sometimes nobody:nogroup etc
+
+chown -R user_name:user_group q-forms
+
+# make sure the file permissions are consistent with the rest of openacs
+
+chmod -R 754 q-forms
+
+# Then start openacs if it isn't already.
+
+# Browse to your website's local url:
+
+/acs-admin/
+
+# click "Install Software"
+
+# click "Install from Local"
+
+# click on the box next to Q-Forms
+
+# click the "Install or update checked applications" button
+
+# follow instructions (usually requiring server restart)
+
+# That's it!
+
Index: openacs-4/packages/q-forms/README.md
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/q-forms/README.md,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/q-forms/README.md 14 Nov 2014 18:27:52 -0000 1.1
@@ -0,0 +1,72 @@
+Q-Forms
+=======
+
+The lastest version of the code is available at the site:
+ http://github.com/dcpm/q-forms
+
+introduction
+------------
+
+Q-Forms provides procedures for building forms dynamically in OpenACS.
+It is an OpenACS service package that allows convenient building and
+interpreting of web-based forms via tcl in a web page.
+
+Q-Forms procedures parallel html's form tags with many automatic
+defaults that remove the tedious nature of building forms
+via html or an alternate form building context, such as OpenACS form
+builder, ad_form or acs-templating.
+
+license
+-------
+Copyright (c) 2013 Benjamin Brink
+po box 20, Marylhurst, OR 97036-0020 usa
+email: tekbasse@yahoo.com
+
+Q-Forms is open source and published under the GNU General Public License,
+consistent with the OpenACS system: http://www.gnu.org/licenses/gpl.html
+A local copy is available at q-forms/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
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+features
+--------
+
+Low learning-curve. Uses tcl context. Procedures match tags. List friendly.
+
+Built-in API defaults. Takes less keystrokes to build a form than typing manually.
+
+Can build multiple forms concurently using Tcl file terminology.
+
+No limitations to building dynamic forms with specialized inputs.
+
+Form values are retrieved as an array named by the programmer.
+
+Form values are automatically quoted, a requirement of secure input handling.
+
+Optional automatic hash generation helps secure form transactions
+and ignores multiple posts caused from mouse double-clicks and browsing page history.
+
+Multiple values of same key can be combined as a list (instead of producing
+a form post error).
+
+html can be inserted in any form at any point during the build.
+
+No UI javascript is used. Technologies with limited UI or cpu power can use it.
+
+Integrates with acs-templating features.
+
+
+installation
+------------
+See file q-forms/INSTALL.TXT for directions on installing.
Index: openacs-4/packages/q-forms/q-forms.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/q-forms/q-forms.info,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/q-forms/q-forms.info 14 Nov 2014 18:27:52 -0000 1.1
@@ -0,0 +1,28 @@
+<?xml version="1.0"?>
+<!-- Generated by the OpenACS Package Manager -->
+
+<package key="q-forms" url="http://openacs.org/repository/apm/packages/q-forms" type="apm_service">
+ <package-name>Q-Forms</package-name>
+ <pretty-plural>Q-Forms</pretty-plural>
+ <initial-install-p>f</initial-install-p>
+ <singleton-p>t</singleton-p>
+ <implements-subsite-p>f</implements-subsite-p>
+ <inherit-templates-p>f</inherit-templates-p>
+
+ <version name="0.035" url="http://openacs.org/repository/download/apm/q-forms-0.035.apm">
+ <owner url="mailto:tekbasse@yahoo.com">Benjamin Brink</owner>
+ <owner url="http://openacs.org">OpenACS Community</owner>
+ <summary>Provides code for building forms dynamically in tcl</summary>
+ <description format="text/plain">Provides qf_* form bulding and interpreting procedures, especially designed for building forms dynamically.</description>
+ <maturity>1</maturity>
+
+ <provides url="q-forms" version="0.035"/>
+
+ <callbacks>
+ </callbacks>
+ <parameters>
+ <!-- No version parameters -->
+ </parameters>
+
+ </version>
+</package>
Index: openacs-4/packages/q-forms/tcl/form-helper-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/q-forms/tcl/form-helper-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/q-forms/tcl/form-helper-procs.tcl 14 Nov 2014 18:27:52 -0000 1.1
@@ -0,0 +1,888 @@
+ad_library {
+
+ procedures for helping render form data or presentation for form data
+ @creation-date 15 May 2012
+ @cs-id $Id:
+
+ to vertically align textarea label, add to css:
+
+ textarea { vertical-align: top; }
+ # replace top with middle or other options to adjust alignment.
+ # textarea's border is used for alignment, so alignment is affected by font-size and line-height ratio
+ # in addition to borders and margins.
+
+}
+
+
+
+ad_proc -public qss_txt_to_tcl_list_of_lists {
+ textarea
+ linebreak
+ delimiter
+} {
+ Converts a csv/txt style table into a tcl list_of_lists
+} {
+ set lists_list [list]
+ set row_list [split $textarea $linebreak]
+ # clean the rows of any extra linefeeds etc
+
+ foreach row $row_list {
+ set columns_list [split $row $delimiter]
+ # rebuild columns_list to clean it of any remaining invisible characters
+ set column_set [list ]
+ foreach column $columns_list {
+ regsub -all -- {[\n\r\f\v]} $column {} col_version2
+ regsub -expanded -all -- {[[:cntrl:]]} $col_version2 {} col_version3
+ lappend column_set $col_version3
+ }
+ set columns_list $column_set
+
+ set columns [llength $columns_list]
+# ns_log Notice "qss_txt_to_tcl_list_of_lists: col len $columns, columns_list ${columns_list}"
+ if { $columns > 0 } {
+ lappend lists_list $columns_list
+ }
+ }
+ return $lists_list
+}
+
+ad_proc -public qss_txt_table_stats {
+ textarea
+} {
+ determines the best guess linebreak_char delimiter rows_count columns_count of a cvs/txt table
+ and returns these values a list
+} {
+ # scan to guess # of rows and cols
+
+ set linebreaks_list [list \n \r \f \v ]
+ set array table_arr
+
+ # determine row delimiter
+ set lineC 0
+ set max_rows 0
+ foreach linebreak $linebreaks_list {
+ set row_set [split $textarea $linebreak]
+ set linesC [llength $row_set]
+#ns_log Notice "qss_txt_table_stats: rows $linesC for linebreak_idx/lineC $lineC"
+ if { $linesC > $max_rows } {
+ set linebreak_idx $lineC
+ set max_rows $linesC
+ set linebreak_char $linebreak
+# set rows_set $row_set
+ # remove any remaining delimiters
+ set rows_set [list ]
+ foreach line $row_set {
+ regsub -all -- {[\n\r\f\v]} $line {} line2
+# regsub -expanded -all -- {[[:cntrl:]]} $line2 {} line3
+ lappend rows_set $line2
+ }
+ set rows_count [llength $rows_set]
+ }
+ incr lineC
+ }
+#ns_log Notice "qss_txt_table_stats: rows_set: $rows_set"
+
+
+ set rowsC [llength $rows_set]
+ # determine column delimiter
+ set delimiters_list [list "\t" " " "," "|" "!"]
+
+ set delimC 0
+ set columns_arr(0-avg) 0.
+ foreach delimiter $delimiters_list {
+ array unset columns_arr
+ set max_cols 0
+ set many_cols_sum 0.
+ set few_cols_sum 0.
+ set many_cols_rows 0
+ set few_cols_rows 0
+ set colC_list [list]
+ set cols_sum 0.
+ # get average number of rows and avg variance for each delim
+ # When avg cols/row is > 2 ignore rows with (0 or) one column when calculating avg variance
+ # Do this by counting these rows, averaging them, then averaging to the other set if <= 2.
+
+ # if there is a significant median value, use it instead.
+ foreach row $rows_set {
+ set col_set [split $row $delimiter]
+ set colsC [llength $col_set]
+# ns_log Notice "qss_txt_table_stats: delimiter $delimiter colsC $colsC"
+ if { [info exists columns_arr(${colsC})] } {
+ set columns_arr(${colsC}) [expr { $columns_arr(${colsC}) + 1 } ]
+ } else {
+ set columns_arr(${colsC}) 1
+ }
+ set cols_sum [expr { $cols_sum + $colsC } ]
+ lappend colC_list $colsC
+ if { $colsC > 2 } {
+ set many_cols_sum [expr { $many_cols_sum + $colsC } ]
+ incr many_cols_rows
+ } else {
+ set few_cols_sum [expr { $few_cols_sum + $colsC } ]
+ incr few_cols_rows
+ }
+ }
+ if { $few_cols_rows > 0 } {
+ set few_cols_avg [expr { $few_cols_sum / $few_cols_rows } ]
+ } else {
+ set few_cols_avg 0
+ }
+ if { $many_cols_rows > 0 } {
+ set many_cols_avg [expr { $many_cols_sum / $many_cols_rows } ]
+ } else {
+ set many_cols_avg 0
+ }
+ set cols_avg [expr { $cols_sum / $max_rows } ]
+ if { $cols_avg > 2 } {
+ set cols_avg $many_cols_avg
+# set rowsC $many_cols_rows
+ } else {
+ set cols_avg $few_cols_avg
+# set rowsC $few_cols_rows
+ }
+ # determine variance
+ set sum2 0.
+ set rowCt 0
+ foreach colCt $colC_list {
+ if { $colCt > 0 } {
+ set sum2 [expr { $sum2 + pow( $colCt - $cols_avg , 2. ) } ]
+ incr rowCt
+ }
+ }
+ if { $rowCt > 1 } {
+ set variance [expr { $sum2 / ( $rowCt - 1. ) } ]
+ } else {
+ set variance 99999.
+ }
+
+ #what is median of columns?
+ set median 0
+ foreach { column count } [array get columns_arr] {
+ if { $count > $median } {
+ set median_old $median
+ set median $column
+ }
+ }
+
+ # column count expands (not contracts) if delimeter is shared in data
+ if { $median_old == 0 } {
+ set median_old $median
+ }
+ set median_diff [expr { $median - $median_old } ]
+
+ set median_pct_diff [expr { $median_diff / $median_old } ]
+
+
+ if { $median_pct_diff > 1.1 && $median_pct_diff < 2.0 } {
+ set median_old2 $median_old
+ set median_old $median
+ set median $median_old2
+ }
+# if row and column delimiter are same (such as space), manually step through table collecting info?
+# determine likely matrix size and variations, then step through to sqrt(max_rows) looking for data type patterns.
+# NOT IMPLEMENTED
+
+ # For best guess, the average converges toward the median..
+ set median_diff_abs [expr { abs( $median_diff ) } ]
+ if { $variance < $median_diff_abs && $cols_avg < $median } {
+ set bguess $cols_avg
+ set bguessD $variance
+ } else {
+ set bguess $median
+ set bguessD $median_diff_abs
+ }
+
+ set table_arr(${delimC}-avg) $cols_avg
+ set table_arr(${delimC}-variance) $variance
+ set table_arr(${delimC}-median) $median
+ set table_arr(${delimC}-medianD) $median_old
+ set table_arr(${delimC}-bguess) $bguess
+ set table_arr(${delimC}-bguessD) $bguessD
+ set table_arr(${delimC}-rows) $rowCt
+ set table_arr(${delimC}-delim) $delimiter
+ set table_arr(${delimC}-linebrk) $linebreak_char
+ ns_log Notice "qss_txt_table_stats: delimC '$delimC' delimiter '${delimiter}' cols_avg $cols_avg variance $variance median $median median_old $median_old bguess $bguess bguessD $bguessD rowCt $rowCt"
+ incr delimC
+ }
+
+ # convert the table into a sortable list of lists
+ # First choice:
+ # select bguess >= 2 with smallest variance.
+ set bguess_lists [list ]
+ for { set i 0 } { $i < $delimC } { incr i } {
+ if { $table_arr(${i}-bguess) >= 2. } {
+ set bg_list [list $i $table_arr(${i}-avg) $table_arr(${i}-variance) ]
+ ns_log Notice "qss_txt_table_stats.215: i $i table_arr(${i}-bguess) $table_arr(${i}-bguess) table_arr(${i}-bguessD) $table_arr(${i}-bguessD) bg_list ${bg_list}"
+ lappend bguess_lists $bg_list
+ }
+ }
+ # sort by smallest variance
+ set sorted_bg_lists [lsort -increasing -real -index 2 $bguess_lists]
+ ns_log Notice "qss_txt_table_stats.220: sorted_bg_lists ${sorted_bg_lists}"
+ set i [lindex [lindex $sorted_bg_lists 0] 0]
+ set bguess $table_arr(${i}-bguess)
+ set bguessD $table_arr(${i}-bguessD)
+ set rows_count $table_arr(${i}-rows)
+ set delimiter $table_arr(${i}-delim)
+
+ # If there are no bguesses over 2, then use this process:
+ if { [llength $bguess_lists] == 0 } {
+ # This following techinque is not dynamic enough to handle all conditions.
+ set bguessD $table_arr(0-bguessD)
+ set bguess $table_arr(0-bguess)
+ set rows_count $table_arr(0-rows)
+ set delimiter $table_arr(0-delim)
+ # bguessD is absolute value of bguess from variance
+ for { set i 0 } { $i < $delimC } { incr i } {
+ if { ( $table_arr(${i}-bguessD) <= $bguessD ) && $table_arr(${i}-bguess) > 1 } {
+ if { ( $bguess > 1 && $table_arr(${i}-bguess) < $bguess ) || $bguess < 2 } {
+ set bguess $table_arr(${i}-bguess)
+ set bguessD $table_arr(${i}-bguessD)
+ set rows_count $table_arr(${i}-rows)
+ set delimiter $table_arr(${i}-delim)
+ }
+ }
+ }
+ }
+ ns_log Notice "qss_txt_table_stats linebreak '${linebreak_char}' delim '${delimiter}' rows '${rows_count}' columns '${bguess}'"
+ set return_list [list $linebreak_char $delimiter $rows_count $bguess]
+# ns_log Notice "qss_txt_table_stats: return_list $return_list"
+ return $return_list
+}
+
+
+
+ad_proc -public qss_list_of_lists_to_html_table {
+ table_list_of_lists
+ {table_attribute_list ""}
+ {td_attribute_lists ""}
+} {
+ Converts a tcl list_of_lists to an html table, returns table as text/html
+ table_attribute_list can be a list of attribute pairs to pass to the TABLE tag: attribute1 value1 attribute2 value2..
+ The td_attribute_lists adds attributes to TD tags at the same position as table_list_of_lists
+ the list is represented {row1 {cell1} {cell2} {cell3} .. {cell x} } {row2 {cell1}...}
+ Note that attribute - value pairs in td_attribute_lists can be added uniquely to each TD tag.
+} {
+ set table_html "<table"
+ foreach {attribute value} $table_attribute_list {
+ regsub -all -- {\"} $value {\"} value
+ append table_html " $attribute=\"$value\""
+ }
+ append table_html ">\n"
+ set row_i 0
+ set column_i 0
+ #setup repeat pattern for formatting rows, if last formatting row is not blank
+ set repeat_last_row_p 0
+ if { [llength [lindex $td_attribute_lists end] ] > 0 } {
+ # this feature only comes into play if td_attrubte_lists is not as long as table_list_of_lists
+ set repeat_last_row_p 1
+ set repeat_row [expr { [llength $td_attribute_lists] - 1 } ]
+ }
+ foreach row_list $table_list_of_lists {
+ append table_html "<tr>"
+ foreach column $row_list {
+ append table_html "<td"
+ if { $repeat_last_row_p && $row_i > $repeat_row } {
+ set attribute_value_list [lindex [lindex $td_attribute_lists $repeat_row] $column_i]
+
+ } else {
+ set attribute_value_list [lindex [lindex $td_attribute_lists $row_i] $column_i]
+ }
+ foreach {attribute value} $attribute_value_list {
+ regsub -all -- {\"} $value {\"} value
+ append table_html " $attribute=\"$value\""
+ }
+ append table_html ">${column}</td>"
+ incr column_i
+ }
+ append table_html "</tr>\n"
+ incr row_i
+ set column_i 0
+ }
+ append table_html "</table>\n"
+ return $table_html
+}
+
+ad_proc -public qss_lists_to_text {
+ table_list_of_lists
+ {row_delimiter "\n"}
+ {column_delimiter ","}
+ } {
+ Converts a tcl list_of_lists to content suitable to be used with a textarea tag.
+} {
+ foreach row_list $table_list_of_lists {
+ set col_delim ""
+ foreach column $row_list {
+ append table_html $col_delim
+ append table_html $column
+ set col_delim $column_delimiter
+ }
+ append table_html $row_delimiter
+ }
+ return $table_html
+}
+
+
+ad_proc -public qss_form_table_to_table_lists {
+ table_array_name
+} {
+ returns a table represented as a list of lists from a table represtented as an array.
+} {
+ upvar $table_array_name table_array
+
+ # get array indices as a sorted list
+ set array_idx_list [lsort [array names table_array]]
+}
+
+ad_proc -public qss_table_lists_normalize {
+ table_lists
+ new_min
+ new_max
+} {
+ given a list_of_lists table, returns the table normalized to max/min parameters
+} {
+ set element_1 [lindex [lindex $table_lists 0] 0]
+ set element_max $element_1
+ set element_min $element_1
+ foreach row_list $table_lists {
+ foreach element $row_list {
+ if { $element > $element_max } {
+ set element_max $element
+ }
+ if { $element < $element_min } {
+ set element_min $element
+ }
+ }
+ }
+ set delta_old [expr { $element_max - $element_min } ]
+ set delta_new [expr { $new_max - $new_min } ]
+
+ foreach row_list $table_lists {
+ foreach element $row_list {
+ # transform value to new range
+ set element_new [expr { ( $element - $element_min ) * $delta_new / $delta_old + $new_min } ]
+ }
+ }
+}
+
+
+
+ad_proc -public qss_progression_x1x2xc {
+ min
+ max
+ count
+} {
+ given: x1 start, x2 end, and xc (the number of points)
+
+ returns a list of xc elements starting from x1 to x2
+} {
+
+ set dx [expr { $x2 - $x1 } ]
+ set x_list [list ]
+ if { $xc != 0 && $dx != 0 } {
+ if { $x1 > $x2 } {
+ set step [expr { $dx / $xc } ]
+ for { set x $x1 } { $x >= $x2 } { set x [expr { $x + $step } ] } {
+ lappend x_list $x
+ }
+ } else {
+ set step [expr { $dx / $xc } ]
+ for { set x $x1 } { $x <= $x2 } { set x [expr { $x + $step } ] } {
+ lappend x_list $x
+ }
+ }
+ }
+ return $x_list
+}
+
+ad_proc -public qf_is_natural_number {
+ value
+} {
+ answers question: is value a natural counting number (non-negative integer)?
+ returns 0 or 1
+} {
+ set is_natural [regexp {^(0*)(([1-9][0-9]*|0))$} $value match zeros value]
+ return $is_natural
+}
+
+ad_proc -public qf_remove_from_list {
+ value value_list
+} {
+ removes multiple of a specific value from a list
+ returns list without the passed value
+} {
+
+ set value_indexes [lsearch -all -exact $value_list $value]
+ while { [llength $value_indexes] > 0 } {
+ set next_index [lindex $value_indexes 0]
+ set value_list [lreplace $value_list $next_index $next_index]
+ set value_indexes [lsearch -all -exact $value_list $value]
+ }
+ return $value_list
+}
+
+ad_proc -public qf_get_contents_from_tag {
+ start_tag
+ end_tag
+ page
+ {start_index 0}
+} {
+ Returns content of an html/xml or other bracketing tag that is uniquely identified within a page fragment or string.
+ helps pan out the golden nuggets of data from the waste text when given some garbage with input for example
+} {
+ set tag_contents ""
+ set start_col [string first $start_tag $page $start_index]
+ set end_col [string first $end_tag $page $start_col]
+ if { $end_col > $start_col && $start_col > -1 } {
+ set tag_contents [string trim [string range $page [expr { $start_col + [string length $start_tag] } ] [expr { $end_col -1 } ]]]
+ } else {
+ set starts_with "${start_tag}.*"
+ set ends_with "${end_tag}.*"
+ if { [regexp -- ${starts_with} $page tag_contents ]} {
+ if { [regexp -- ${ends_with} $tag_contents tail_piece] } {
+ set tag_contents [string range $tag_contents 0 [expr { [string length $tag_contents] - [string length $tail_piece] - 1 } ] ]
+ } else {
+ ns_log Notice "Warning no contents for tag $start_tag"
+ set tag_contents ""
+ }
+ }
+ }
+ return $tag_contents
+}
+
+ad_proc -public qf_get_contents_from_tags_list {
+ start_tag
+ end_tag
+ page
+} {
+ Returns content (as a list) of all occurances of an html/xml or other bracketing tag that is somewhat uniquely identified within a page fragment or string.
+ helps pan out the golden nuggets of data from the waste text when given some garbage with input for example
+} {
+ set start_index 0
+ set tag_contents_list [list]
+ set start_tag_len [string length $start_tag]
+ set start_col [string first $start_tag $page 0]
+ set end_col [string first $end_tag $page $start_col]
+ set tag_contents [string range $page [expr { $start_col + $start_tag_len } ] [expr { $end_col - 1 } ]]
+ while { $start_col != -1 && $end_col != -1 } {
+# lappend tag_contents_list [string trim $tag_contents]
+ lappend tag_contents_list $tag_contents
+
+ set start_index [expr { $end_col + 1 }]
+ set start_col [string first $start_tag $page $start_index]
+ set end_col [string first $end_tag $page $start_col]
+ set tag_contents [string range $page [expr { $start_col + $start_tag_len } ] [expr { $end_col - 1 } ]]
+ }
+ return $tag_contents_list
+}
+
+ad_proc -public qf_remove_tag_contents {
+ start_tag
+ end_tag
+ page
+} {
+ Returns everything but the content between start_tag and end_tag (as a list)
+ of all occurances on either side of an html/xml or other bracketing tag
+ that is somewhat uniquely identified within a page fragment or string.
+ This is handy to remove script tags and < ! - - web comments - - > etc
+ helps pan out the golden nuggets of data from the waste text when given some garbage with input for example
+} {
+ # start and end refer to the tags and their contents that are to be removed
+ns_log Notice "qf_remove_tag_contents: start_tag $start_tag end_tag $end_tag page $page"
+ set start_index 0
+ set tag_contents_list [list]
+ set start_tag_len [string length $start_tag]
+ set end_tag_len [string length $end_tag]
+ set start_col [string first $start_tag $page $start_index]
+ set end_col [string first $end_tag $page $start_col]
+ # set tag_contents [string range $page 0 [expr { $start_col - 1 } ] ]
+ while { $start_col != -1 && $end_col != -1 } {
+ set tag_contents [string range $page $start_index [expr { $start_col - 1 } ] ]
+# lappend tag_contents_list [string trim $tag_contents]
+ lappend tag_contents_list $tag_contents
+ns_log Notice "qf_remove_tag_contents(465): tag_contents '$tag_contents'"
+ # start index is where we begin the next clip
+ set start_index [expr { $end_col + $end_tag_len } ]
+ set start_col [string first $start_tag $page $start_index]
+ set end_col [string first $end_tag $page $start_col]
+ # and the new clip ends at the start of the next tag
+ }
+ # append any trailing portion
+ lappend tag_contents_list [string range $page $start_index end]
+# set remaining_contents \[join $tag_contents_list " "\]
+ return $tag_contents_list
+}
+
+
+ad_proc -public qf_convert_html_list_to_tcl_list {
+ html_list
+} {
+ converts a string containing an html list to a tcl list
+ Assumes there are no embedded sublists, and strips remaining html
+} {
+ set draft_list $html_list
+
+ #we standardize the start and end of the list, so we know where to clip
+
+ if { [regsub -nocase -- {<[ou][l][^\>]*>} $draft_list "<ol>" draft_list ] ne 1 } {
+ # no ol/ul tag, lets create the list container anyway
+ set draft_list "<ol> ${draft_list}"
+
+ } else {
+ # ol/ul tag exists, trim garbage before list
+ set draft_list [string range $draft_list [string first "<ol>" $draft_list ] end ]
+ }
+
+ if { [regsub -nocase -- {</li>[ ]*</[ou]l[^\>]*>} $draft_list "</li></ol>" draft_list ] ne 1 } {
+ # end list tag may not exist or is not in standard form
+ if { [regsub -nocase -- {</[ou]l[^\>]*>} $draft_list "</li></ol>" draft_list ] ne 1 } {
+ # assume for now that there was no end li tag before the list (bad html)
+ } else {
+ # no ol/ul list tag, assume no end </li> either?
+ append draft_list "</li></ol>"
+ }
+ }
+
+ # end ol tag exists, trim garbage after list
+ # choosing the last end list tag in case there is a list in one of the lists
+ set draft_list [string range $draft_list 0 [expr { [string last "</ol>" $draft_list ] + 4} ] ]
+
+ # simplify li tags, with a common delimiter
+ regsub -nocase -all -- {<li[^\>]*>} $draft_list {|} draft_list
+ # remove other html tags
+
+ set draft_list [qf_webify $draft_list]
+
+ # remove excess spaces
+ regsub -all -- {[ ]+} $draft_list " " draft_list
+ set draft_list [string trim $draft_list]
+
+ # remove excess commas and format poorly placed ones
+ regsub -all -- {[ ],} $draft_list "," draft_list
+
+ regsub -all -- {[,]+} $draft_list "," draft_list
+
+ # put colons in good form
+ regsub -all -- {[ ]:} $draft_list ":" draft_list
+
+ regsub -all -- {:,} $draft_list ":" draft_list
+ # remove : in cases where first column is blank, ie li should not start with a colon
+
+ regsub -all -- {\|:} $draft_list {|} draft_list
+
+ set tcl_list [split $draft_list {|}]
+ # first lindex will be blank, so remove it
+ set tcl_list [lrange $tcl_list 1 end]
+#ns_log Notice "qf_convert_html_list_to_tcl_list: tcl_list $tcl_list"
+ return $tcl_list
+}
+
+ad_proc -public qf_convert_html_table_to_list {
+ html_string
+ {list_style ul}
+} {
+ converts a string containing an html table to an html list
+ assumes first column is a heading (with no rows as headings), and remaining columns are values
+ defaults to li list style, should return list in good html form even if table is not quite that way
+} {
+
+ if { [regsub -nocase -- {<table[^\>]*>} $html_string "<${list_style}>" draft_list ] ne 1 } {
+ # no table tag, lets create the list container anyway
+ set draft_list "<${list_style}> ${html_string}"
+ } else {
+ # table tag exists, trim garbage before list
+ set draft_list [string range $draft_list [string first "<${list_style}>" $draft_list ] end ]
+ }
+
+ if { [regsub -nocase -- {</tr>[ ]*</table[^\>]*>} $draft_list "</li></${list_style}>" draft_list ] ne 1 } {
+ # end table tag may not exist or is not in standard form
+ if { [regsub -nocase -- {</table[^\>]*>} $draft_list "</li></${list_style}>" draft_list ] ne 1 } {
+ # assume for now that there was no end tr tag before the table (bad html)
+ } else {
+ # no table tag, assume no end </tr> either?
+ append draft_list "</li></${list_style}>"
+ }
+ }
+
+ # end table tag exists, trim garbage after list
+ # choosing the last end list tag in case there is a list in one of the table cells
+ set draft_list [string range $draft_list 0 [expr { [string last "</${list_style}>" $draft_list ] + 4} ] ]
+
+ # simplify tr and td tags, but do not replace yet, because we want to use them for markers when replacing td tags
+ regsub -nocase -all -- {<tr[^\>]+>} $draft_list "<tr>" draft_list
+ regsub -nocase -all -- {</tr[^\>]+>} $draft_list "</tr>" draft_list
+ regsub -nocase -all -- {<td[^\>]+>} $draft_list "<td>" draft_list
+ regsub -nocase -all -- {</td[^\>]+>} $draft_list "</td>" draft_list
+
+ # clean out other content junk tags
+ regsub -nocase -all -- {<[^luot\/\>][^\>]*>} $draft_list "" draft_list
+ regsub -nocase -all -- {</[^luot\>][^\>]*>} $draft_list "" draft_list
+
+ set counterA 0
+ while { [string match -nocase "*<tr>*" $draft_list ] } {
+
+ if { [incr counterA ] > 300 } {
+ ns_log Error "convert_html_table_to_list, ref: counterA detected possible infinite loop."
+ doc_adp_abort
+ }
+ # get row range
+ set start_tr [string first "<tr>" $draft_list ]
+ set end_tr [string first "</tr>" $draft_list ]
+
+ # make sure that the tr end tag matches the current tr tag
+ if { $end_tr == -1 } {
+ set next_start_tr [string first "<tr>" $draft_list [expr { $start_tr + 4 } ] ]
+ } else {
+ set next_start_tr [string first "<tr>" $draft_list $end_tr ]
+ }
+
+ regsub -- {<tr>} $draft_list "<li>" draft_list
+
+ if { $end_tr < $next_start_tr && $end_tr > -1 } {
+ regsub -- {</tr>} $draft_list " " draft_list
+ # common sense says we replace </tr> with </li>, but then there may be cases missing a </tr>
+ # and if so, we would have to insert a </li> which would mess up the position values for use
+ # later on. Instead, at the end, we convert <li> to </li><li> and take care of the special 1st and last cases
+ }
+
+ # we are assuming any td/tr tags occur within the table, since table has been trimmed above
+ set start_td [string first "<td>" $draft_list ]
+ set end_td [string first "</td>" $draft_list ]
+ set next_start_td [string first "<td>" $draft_list [expr { $start_td + 3 } ] ]
+
+ if { $next_start_td == -1 || ( $next_start_td > $next_start_tr && $next_start_tr > -1 )} {
+ # no more td tags for this row.. only one column in this table
+
+ } else {
+ # setup first special case of first column
+ # replacing with strings of same length to keep references current throughout loops
+ set draft_list [string replace $draft_list $start_td [expr { $start_td + 3 } ] " " ]
+
+ if { $end_td < $next_start_tr && $end_td > -1 } {
+ # there is an end td tag for this td cell, replace with :
+ set draft_list [string replace $draft_list $end_td [expr { $end_td + 4 } ] ": " ]
+
+ } else {
+ # insert special case, just prior to new td tag
+ set draft_list "[string range ${draft_list} 0 [expr { ${next_start_td} - 1 } ] ]: [string range ${draft_list} ${next_start_td} end ]"
+ if { $next_start_tr > 0 } {
+ incr next_start_tr 2
+ }
+ }
+ }
+
+ # process remaining td cells in row, separating cells by comma
+ set column_separator " "
+ if { $next_start_tr == -1 } {
+ set end_of_row [string length $draft_list ]
+ } else {
+ set end_of_row [expr { $next_start_tr + 3 } ]
+ }
+
+ set columns_to_convert [string last "<td>" [string range $draft_list 0 $end_of_row ] ]
+ set counterB 0
+ while { $columns_to_convert > -1 } {
+
+ if { [incr counterB ] > 200 } {
+ ns_log Error "convert_html_table_to_list, ref: counterB detected possible infinite loop."
+ doc_adp_abort
+ }
+
+ set start_td [string first "<td>" $draft_list ]
+ set end_td [string first "</td>" $draft_list ]
+ set next_start_td [string first "<td>" $draft_list [expr { $start_td + 3 } ] ]
+
+ if { $next_start_td == -1 } {
+ # no more td tags for all rows.. still need to process this one.
+ set columns_to_convert -1
+ set draft_list [string replace $draft_list $start_td [expr { $start_td + 3 } ] $column_separator ]
+
+ } elseif { ( $next_start_td > $next_start_tr && $next_start_tr > -1 ) } {
+ # no more td tags for this row..
+ set columns_to_convert -1
+
+ } else {
+ # add a comma before the value, if this is not the first value
+ set draft_list [string replace $draft_list $start_td [expr { $start_td + 3 } ] $column_separator ]
+
+ }
+
+ if { $end_td > -1 && ( $end_td < $next_start_td || $next_start_td == -1 ) } {
+ # there is an end td tag for this td cell, remove it
+ regsub -- {</td>} $draft_list "" draft_list
+ }
+
+ set column_separator ", "
+ # next column
+ }
+
+
+ # next row
+ }
+
+ # clean up list, add </li>
+ regsub -all -- "<li>" $draft_list "</li><li>" draft_list
+ # change back first case
+ regsub -- "</li><li>" $draft_list "<li>" draft_list
+ # a /li tag is already included with the list container end tag
+
+ # remove excess spaces
+ regsub -all -- {[ ]+} $draft_list " " draft_list
+
+ # remove excess commas and format poorly placed ones
+ regsub -all -- {[ ],} $draft_list "," draft_list
+ regsub -all -- {[,]+} $draft_list "," draft_list
+
+ # put colons in good form
+ regsub -all -- {[ ]:} $draft_list ":" draft_list
+ regsub -all -- {:,} $draft_list ":" draft_list
+ # remove : in cases where first column is blank, ie li should not start with a colon
+ regsub -all -- {<li>:} $draft_list "<li>" draft_list
+
+ return $draft_list
+}
+ad_proc -public qf_remove_html {
+ description
+ {delimiter ":"}
+} {
+
+ remvoves html and converts common delimiters to something that works in html tag attributes, default delimiter is ':'
+
+} {
+ # remove tags
+ regsub -all -- "<\[^\>\]*>" $description " " description
+
+ # convert fancy delimiter to one that complies with meta tag values
+ regsub -all -- "&\#187;" $description $delimiter description
+
+ # convert bracketed items as separate (delimited) items
+ regsub -all -- {\]} $description "" description
+ regsub -all -- {\[} $description $delimiter description
+
+ # convert any dangling lt/gt signs to delimiters
+ regsub -all -- ">" $description $delimiter description
+ regsub -all -- "<" $description $delimiter description
+
+ # remove characters that
+ # can munge some meta tag values or how they are interpreted
+ regsub -all -- {\'} $description {} description
+ regsub -all -- {\"} $description {} description
+
+ # remove html entities, such as ™ © etc.
+ regsub -all -nocase -- {&[a-z]+;} $description {} description
+
+ # filter extra spaces
+ regsub -all -- {\s+} $description { } description
+ set description "[string trim $description]"
+
+return $description
+}
+
+ad_proc -public qf_remove_attributes_from_html {
+ description
+} {
+
+ remvoves attributes from html
+
+} {
+ # filter extra spaces
+ regsub -all -- {\s+} $description { } description
+ set description "[string trim $description]"
+
+ # remove attributes from tags
+ regsub -all -nocase -- {(<[/]?[a-z]*)[^\>]*(\>)} $description {\1\2} description
+
+return $description
+}
+
+ad_proc -public qf_abbreviate {
+ phrase
+ {max_length {}}
+} {
+ abbreviates a pretty title or phrase to first word, or to max_length characters if max_length is a number > 0
+} {
+ set suffix ".."
+ set suffix_len [string length $suffix]
+
+ if { [ad_var_type_check_number_p $max_length] && $max_length > 0 } {
+ set phrase_len_limit [expr { $max_length - $suffix_len } ]
+ regsub -all -- { / } $phrase {/} phrase
+ if { [string length $phrase] > $max_length } {
+ set cat_end [expr { [string last " " [string range $phrase 0 $max_length] ] - 1 } ]
+ if { $cat_end < 0 } {
+ set cat_end $phrase_len_limit
+ }
+ set phrase [string range $phrase 0 $cat_end ]
+ append phrase $suffix
+ regsub {[^a-zA-Z0-9]+\.\.} $phrase $suffix phrase
+ }
+ regsub -all -- { } $phrase {\ } phrase
+ set abbrev_phrase $phrase
+
+ } else {
+ regsub -all { .*$} $phrase $suffix abbrev1
+ regsub -all {\-.*$} $abbrev1 $suffix abbrev
+ regsub -all {\,.*$} $abbrev $suffix abbrev1
+ set abbrev_phrase $abbrev1
+ }
+ return $abbrev_phrase
+}
+
+ad_proc -public qf_webify {
+ description
+} {
+ standardizes and sanitizes some junky data for use in web content
+} {
+ # need to remove code between script tags and hidden comments
+ set description_list [qf_remove_tag_contents {<script} {</script>} $description ]
+ set description_new ""
+ foreach desc_part $description_list {
+ append description_new $desc_part
+ }
+ set description_list [qf_remove_tag_contents {<!--} {-->} $description_new ]
+ set description_new ""
+ foreach desc_part $description_list {
+ append description_new $desc_part
+ }
+ regsub -all "<\[^\>\]*>" $description_new "" description1
+ regsub -all "<" $description1 ":" description
+ regsub -all ">" $description ":" description1
+ regsub -all -nocase {\"} $description1 {} description
+ regsub -all -nocase {\'} $description {} description1
+ regsub -all -nocase {&[a-z]+;} $description1 {} description
+ return $description
+}
+
+ad_proc -public qf_is_decimal {
+ value
+} {
+ checks if value is a decimal number that can be used in tcl decimal math. Returns 1 if true, otherwise 0.
+} {
+ # following regexp from acs-tcl/tcl/json-procs.tcl which references json.org, ietf.org, Thomas Maeder, Glue Software Engineering AG and Don Baccus
+
+ # tokens consisting of a single character
+ #variable singleCharTokens { "{" "}" ":" "\\[" "\\]" "," }
+ #variable singleCharTokenRE "\[[join $singleCharTokens {}]\]"
+
+ # quoted string tokens
+ #variable escapableREs { "[\\\"\\\\/bfnrt]" "u[[:xdigit:]]{4}" }
+ #variable escapedCharRE "\\\\(?:[join $escapableREs |])"
+ #variable unescapedCharRE {[^\\\"]}
+ #variable stringRE "\"(?:$escapedCharRE|$unescapedCharRE)*\""
+
+ # (unquoted) words
+ #variable wordTokens { "true" "false" "null" }
+ #variable wordTokenRE [join $wordTokens "|"]
+
+ # number tokens
+ # negative lookahead (?!0)[[:digit:]]+ might be more elegant, but
+ # would slow down tokenizing by a factor of up to 3!
+ set positiveRE {[1-9][[:digit:]]+[.]?|[[:digit:]][.]?}
+ set cardinalRE "-?(?:$positiveRE)?"
+ set fractionRE {[.][[:digit:]]+}
+ set exponentialRE {[eE][+-]?[[:digit:]]+}
+ set numberRE "^${cardinalRE}(?:$fractionRE)?(?:$exponentialRE)?$"
+ set type_decimal_p [regexp -- $numberRE $value]
+ return $type_decimal_p
+}
+
Index: openacs-4/packages/q-forms/tcl/form-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/q-forms/tcl/form-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/q-forms/tcl/form-procs.tcl 14 Nov 2014 18:27:52 -0000 1.1
@@ -0,0 +1,1564 @@
+ad_library {
+
+ routines for creating, managing input via html forms
+ @creation-date 21 Nov 2010
+ @cs-id $Id:
+}
+
+# use _ to clear a new default
+# use upvar to grab previous defaults and re-use (with qf_input only)
+# main namespace vars:
+# __form_input_arr = array that contains existing form input and defaults, only one form can be posted at a time
+# __form_ids_list = list that contains existing form ids
+# __form_ids_open_list = list that contains ids of forms that are not closed
+# __form_ids_fieldset_open_list = list that contains form ids where a fieldset tag is open
+# __form_arr contains an array of forms. Each form built as a string by appending tags, indexed by form_id, for example __form_arr($id)
+# __qf_arr contains last attribute values of a tag (for all forms), indexed by {tag}_attribute, __form_last_id is in __qf_arr(form_id)
+# a blank id passed in anything other than qf_form assumes the current (most recent used form_id)
+
+# to fix: id for nonform tag should not be same as form_id. use an attribute "form_id" for assigning tags to specific forms.
+
+#use following to limit access to page requests via post.. to reduce vulnerability to url hack and insertion attacks from web:
+#if { [ad_conn method] != POST } {
+# ad_script_abort
+#}
+#also see patch: http://openacs.org/forums/message-view?message_id=182057
+
+# for early example and discussion, see http://openacs.org/forums/message-view?message_id=3602056
+
+ad_proc -private qf_form_key_create {
+ {key_id ""}
+ {action_url "/"}
+ {instance_id ""}
+} {
+ creates the form key for a more secure form transaction. Returns the security hash. See also qf_submit_key_accepted_p
+} {
+ # This proc is inspired from sec_random_token
+ if { $instance_id eq "" } {
+ # set instance_id package_id
+ set instance_id [ad_conn package_id]
+ }
+# set time_sec \[ns_time\]
+# need more time separation
+ if { $key_id eq "" } {
+ set key_id [expr { int( [clock clicks] * [ns_rand] ) } ]
+ }
+ set time_sec [clock clicks -milliseconds]
+ set start_clicks [ad_conn start_clicks]
+ if { [ad_conn -connected_p] } {
+ set client_ip [ns_conn peeraddr]
+ # set request \[ad_conn request\]
+ set secure_p [security::secure_conn_p]
+ set session_id [ad_conn session_id]
+ set action_url [ns_conn url]
+ # set render_timestamp $time_sec
+ } else {
+ set server_ip [ns_config ns/server/[ns_info server]/module/nssock Address]
+ if { $server_ip eq "" } {
+ set server_ip "127.0.0.1"
+ }
+ set client_ip $server_ip
+ # time_sec s/b circa clock seconds
+ #set request \[string range $time_sec \[expr { floor( ( \[ns_rand\] * \[string length $time_sec\] ) ) }\] end\]
+ set secure_p [expr { floor( [ns_rand] + 0.5 ) } ]
+
+ set session_id [expr { floor( $time_sec / 4 ) } ]
+# set action_url "/"
+# set render_timestamp $time_sec
+ }
+ append sec_hash_string $start_clicks $session_id $secure_p $client_ip $action_url $time_sec $key_id
+ set sec_hash [ns_sha1 $sec_hash_string]
+ db_dml qf_form_key_create {insert into qf_key_map
+ (instance_id,rendered_timestamp,sec_hash,key_id,session_id,action_url,secure_conn_p,client_ip)
+ values (:instance_id,:time_sec,:sec_hash,:key_id,:session_id,:action_url,:secure_p,:client_ip) }
+ return $sec_hash
+}
+
+ad_proc -private qf_submit_key_accepted_p {
+ {sec_hash ""}
+ {instance_id ""}
+} {
+ Checks the form key against existing ones. Returns 1 if matches and unexpired, otherwise returns 0.
+} {
+ # This proc is inspired from sec_random_token
+ if { $instance_id eq "" } {
+ # set instance_id package_id
+ set instance_id [ad_conn package_id]
+ }
+ set connected_p [ad_conn -connected_p]
+ if { $connected_p } {
+ set client_ip [ns_conn peeraddr]
+ set secure_p [security::secure_conn_p]
+ set session_id [ad_conn session_id]
+ set action_url [ns_conn url]
+
+ } else {
+ set server_ip [ns_config ns/server/[ns_info server]/module/nssock Address]
+ if { $server_ip eq "" } {
+ set server_ip "127.0.0.1"
+ }
+ set client_ip $server_ip
+ set secure_p ""
+ set session_id ""
+ set action_url [ns_conn url]
+ }
+ # the key_id is used to help generate unpredictable hashes, but isn't used at this level of input validation
+ set accepted_p [db_0or1row qf_form_key_check_hash {
+ select session_id as session_id_i, action_url as action_url_i, secure_conn_p as secure_conn_p_i, client_ip as client_ip_i from qf_key_map
+ where instance_id =:instance_id and sec_hash =:sec_hash and submit_timestamp is null } ]
+ if { !$accepted_p } {
+ # there is nothing to compare. log current values:
+ ns_log Warning "qf_submit_key_accepted_p: is false. action_url '$action_url' sec_hash '$sec_hash'"
+ if { $connected_p } {
+ ns_log Warning "qf_submit_key_accepted_p: session_id '$session_id' secure_p '$secure_p' client_ip '$client_ip'"
+ }
+ } else {
+ # Mark the key expired
+ set submit_timestamp [ns_time]
+ db_dml qf_form_key_expire { update qf_key_map
+ set submit_timestamp = :submit_timestamp where instance_id =:instance_id and sec_hash =:sec_hash and submit_timestamp is null }
+ }
+ return $accepted_p
+}
+
+
+
+ad_proc -public qf_get_inputs_as_array {
+ {form_array_name "__form_input_arr"}
+ {arg1 ""}
+ {arg2 ""}
+ {arg3 ""}
+ {arg4 ""}
+ {arg5 ""}
+ {arg6 ""}
+} {
+ Get inputs from form submission, quotes all input values. Use ad_unquotehtml to unquote a value.
+ Returns 1 if form inputs exist, otherwise returns 0.
+ If duplicate_key_check is 1, checks if an existing key/value pair already exists, otherwise just overwrites existing value.
+ Overwriting is programmatically useful to overwrite preset defaults, for example.
+} {
+ # get args
+ upvar 1 $form_array_name __form_input_arr
+ set array __form_buffer_arr
+ set arg_arr(duplicate_key_check) 0
+ set arg_arr(multiple_key_as_list) 0
+ set arg_arr(hash_check) 0
+ set arg_full_list [list duplicate_key_check multiple_key_as_list hash_check]
+ set arg_list [list $arg1 $arg2 $arg3 $arg4 $arg5 $arg6 ]
+ set args_list [list]
+ foreach {name value} $arg_list {
+ set arg_index [lsearch -exact $arg_full_list $name]
+ if { $arg_index > -1 } {
+ set arg_arr($name) $value
+ } elseif { $value eq "" } {
+ # ignore
+ } else {
+ ns_log Error "qf_get_inputs_as_array: $name is not a valid name invoked with name value pairs. Separate each with a space."
+ }
+ }
+
+ # get form variables passed with connection
+ set __form_input_exists 0
+ set __form [ns_getform]
+ if { $__form eq "" } {
+ set __form_size 0
+ } else {
+ set __form_size [ns_set size $__form]
+ }
+ #ns_log Notice "qf_get_inputs_as_array: formsize $__form_size"
+ for { set __form_counter_i 0 } { $__form_counter_i < $__form_size } { incr __form_counter_i } {
+
+ regexp -nocase -- {^[a-z][a-z0-9_\.\:\(\)]*} [ns_set key $__form $__form_counter_i] __form_key
+ # Why doesn't work for regexp -nocase -- {^[a-z][a-z0-9_\.\:\(\)]*$ } ?
+ set __form_key_exists [info exists __form_key]
+ # ns_log Notice "qf_get_inputs_as_array: __form_key_exists = ${__form_key_exists}"
+
+ # no inserting tcl commands etc!
+ if { $__form_key_exists == 0 || ( $__form_key_exists == 1 && [string length $__form_key] == 0 ) } {
+ # let's make this an error for now, so we log any attempts
+# ns_log Notice "qf_get_inputs_as_array: __form_key_exists ${__form_key_exists} length __form_key [string length ${__form_key}]"
+ # ns_log Notice "qf_get_inputs_as_array(ref156: attempt to insert unallowed characters to user input '{__form_key}' as '[ns_set key $__form $__form_counter_i]' for counter ${__form_counter_i}."
+ if { $__form_counter_i > 0 } {
+ ns_log Notice "qf_get_inputs_as_array: attempt to insert unallowed characters to user input '{__form_key}'."
+ }
+ } else {
+ set __form_key [ad_quotehtml $__form_key]
+ # The name of the argument passed in the form
+ # no legitimate argument should be affected by quoting:
+
+ # This is the value
+ set __form_input [ad_quotehtml [ns_set value $__form $__form_counter_i]]
+
+ set __form_input_exists 1
+ # check for duplicate key?
+ if { $arg_arr(duplicate_key_check) && [info exists __form_buffer_arr($__form_key) ] } {
+ if { $__form_input ne $__form_buffer_arr($__form_key) } {
+ # which one is correct? log error
+ ns_log Error "qf_get_form_input: form input error. duplcate key provided for ${__form_key}"
+ ad_script_abort
+ # set __form_input_exists to -1 instead of ad_script_abort?
+ } else {
+ ns_log Warning "qf_get_form_input: notice, form has a duplicate key with multiple values containing same info.."
+ }
+ } elseif { $arg_arr(multiple_key_as_list) } {
+ ns_log Notice "qf_get_inputs_as_array: A key has been posted with multible values. Values assigned to the key as a list."
+ if { [llength $__form_buffer_arr($__form_key)] > 1 } {
+ # value is a list, lappend
+ lappend __form_buffer_arr($__form_key) $__form_input
+ } else {
+ # convert the key value to a list
+ set __value_one $__form_buffer_arr($__form_key)
+ unset __form_buffer_arr($__form_key)
+ set __form_buffer_arr($__form_key) [list $__value_one $__form_input]
+ }
+ } else {
+ set __form_buffer_arr($__form_key) $__form_input
+# ns_log Debug "qf_get_inputs_as_array: set ${form_array_name}($__form_key) '${__form_input}'."
+ }
+
+ # next key-value pair
+ }
+ }
+ if { $arg_arr(hash_check) } {
+ if { [info exists __form_buffer_arr(qf_security_hash) ] } {
+ set accepted_p [qf_submit_key_accepted_p $__form_buffer_arr(qf_security_hash) ]
+ if { $accepted_p } {
+ unset __form_buffer_arr(qf_security_hash)
+ array set __form_input_arr [array get __form_buffer_arr]
+ return $__form_input_exists
+ } else {
+ ns_log Notice "qf_get_inputs_as_array: hash_check with form input of '$__form_buffer_arr(qf_security_hash)' did not match."
+ return 0
+ }
+ } else {
+ set accepted_p 0
+ ns_log Notice "qf_get_inputs_as_array: hash_check requires qf_security_hash, but was not included with form input."
+ return 0
+ }
+ } else {
+ array set __form_input_arr [array get __form_buffer_arr]
+ return $__form_input_exists
+ }
+}
+
+ad_proc -public qf_remember_attributes {
+ {arg1 "1"}
+} {
+ Changes qf_* form building procs to use the previous attributes and their values used with the last tag of same type (input,select,button etc) if arg1 is 1.
+} {
+ upvar __qf_remember_attributes __qf_remember_attributes
+ if { $arg1 eq 0 } {
+ set __qf_remember_attributes 0
+ } else {
+ set __qf_remember_attributes 1
+ }
+}
+
+ad_proc -public qf_form {
+ {arg1 ""}
+ {arg2 ""}
+ {arg3 ""}
+ {arg4 ""}
+ {arg5 ""}
+ {arg6 ""}
+ {arg7 ""}
+ {arg8 ""}
+ {arg9 ""}
+ {arg10 ""}
+ {arg11 ""}
+ {arg12 ""}
+ {arg13 ""}
+ {arg14 ""}
+ {arg15 ""}
+ {arg16 ""}
+ {arg17 ""}
+ {arg18 ""}
+ {arg19 ""}
+ {arg20 ""}
+ {arg21 ""}
+ {arg22 ""}
+} {
+ Initiates a form with form tag and supplied attributes. Returns an id. A clumsy url based id is provided if not passed (not recommended).
+ If hash_check passed, creates a hash to be checked on submit for server-client transaction continuity.
+} {
+ # use upvar to set form content, set/change defaults
+ # __qf_arr contains last attribute values of tag, indexed by {tag}_attribute, __form_last_id is in __qf_arr(form_id)
+ upvar 1 __form_ids_list __form_ids_list
+ upvar 1 __form_arr __form_arr
+ upvar 1 __form_ids_open_list __form_ids_open_list
+ upvar 1 __qf_remember_attributes __qf_remember_attributes
+ upvar 1 __qf_arr __qf_arr
+
+ # if proc was passed a list of parameters, parse
+ if { [llength $arg1] > 1 && [llength $arg2] == 0 } {
+ set arg1_list $arg1
+ set lposition 1
+ foreach arg $arg1_list {
+ set arg${lposition} $arg
+ incr lposition
+ }
+ unset arg1_list
+ }
+
+ set attributes_tag_list [list action class id method name style target title]
+ set attributes_full_list $attributes_tag_list
+ lappend attributes_full_list form_id hash_check key_id
+ set arg_list [list $arg1 $arg2 $arg3 $arg4 $arg5 $arg6 $arg7 $arg8 $arg9 $arg10 $arg11 $arg12 $arg13 $arg14 $arg15 $arg16 $arg17 $arg18 $arg19 $arg20 $arg21 $arg22]
+ set attributes_list [list]
+ foreach {attribute value} $arg_list {
+ set attribute_index [lsearch -exact $attributes_full_list $attribute]
+ if { $attribute_index > -1 } {
+ set attributes_arr($attribute) $value
+ if { [lsearch -exact $attributes_tag_list $attribute] > -1 } {
+ lappend attributes_list $attribute
+ }
+ } elseif { $value eq "" } {
+ # ignore
+ } else {
+ ns_log Error "qf_form: $attribute is not a valid attribute. invoke with attribute value pairs. Separate each with a space."
+ }
+ }
+ if { ![info exists attributes_arr(method)] } {
+ set attributes_arr(method) "post"
+ lappend attributes_list "method"
+ }
+# if html5 should we default novalidate to novalidate? No for now.
+
+ if { ![info exists __qf_remember_attributes] } {
+ set __qf_remember_attributes 0
+ }
+ if { ![info exists __form_ids_list] } {
+ set __form_ids_list [list]
+ }
+ if { ![info exists __form_ids_open_list] } {
+ set __form_ids_open_list [list]
+ }
+ # use previous tag attribute values?
+ if { $__qf_remember_attributes } {
+ foreach attribute $attributes_list {
+ if { $attribute ne "id" && ![info exists attributes_arr($attribute)] && [info exists __qf_arr(form_$attribute)] } {
+ set attributes_arr($attribute) $__qf_arr(form_$attribute)
+ }
+ }
+ }
+ # every form gets a form_id
+ set form_id_exists [info exists attributes_arr(form_id) ]
+ if { $form_id_exists == 0 || ( $form_id_exists == 1 && $attributes_arr(form_id) eq "" ) } {
+ set id_exists [info exists attributes_arr(id) ]
+ if { $id_exists == 0 || ( $id_exists == 1 && $attributes_arr(id) eq "" ) } {
+ regsub {/} [ad_conn url] {-} form_key
+ append form_key "-[llength $__form_ids_list]"
+ } else {
+ # since a FORM id has to be unique, lets use it
+ set form_key $attributes_arr(id)
+ }
+ set attributes_arr(form_id) $form_key
+ ns_log Notice "qf_form: generating form_id $attributes_arr(form_id)"
+ }
+
+ # prepare attributes to process
+ set tag_attributes_list [list]
+ foreach attribute $attributes_list {
+ set __qf_arr(form_$attribute) $attributes_arr($attribute)
+ # if a form tag requires an attribute, the following test needs to be forced true
+ if { $attributes_arr($attribute) ne "" } {
+ lappend tag_attributes_list $attribute $attributes_arr($attribute)
+ }
+ }
+
+ set tag_html "<form[qf_insert_attributes $tag_attributes_list]>"
+ # set results __form_arr
+ append __form_arr($attributes_arr(form_id)) "$tag_html\n"
+ if { [lsearch $__form_ids_list $attributes_arr(form_id)] == -1 } {
+ lappend __form_ids_list $attributes_arr(form_id)
+
+ }
+ if { [lsearch $__form_ids_open_list $attributes_arr(form_id)] == -1 } {
+ lappend __form_ids_open_list $attributes_arr(form_id)
+ }
+
+ # append an input tag for qf_security_hash?
+ if { [info exists attributes_arr(hash_check)] && $attributes_arr(hash_check) eq 1 } {
+ if { ![info exists attributes_arr(key_id) ] } {
+ set attributes_arr(key_id) ""
+ }
+ set tag_html "<input[qf_insert_attributes [list type hidden name qf_security_hash value [qf_form_key_create $attributes_arr(key_id) $attributes_arr(action)]]]>"
+ append __form_arr($attributes_arr(form_id)) "$tag_html\n"
+ ns_log Notice "qf_form: adding $tag_html"
+ }
+
+ set __qf_arr(form_id) $attributes_arr(form_id)
+ return $attributes_arr(form_id)
+}
+
+
+ad_proc -public qf_fieldset {
+ {arg1 ""}
+ {arg2 ""}
+ {arg3 ""}
+ {arg4 ""}
+ {arg5 ""}
+ {arg6 ""}
+ {arg7 ""}
+ {arg8 ""}
+ {arg9 ""}
+ {arg10 ""}
+ {arg11 ""}
+ {arg12 ""}
+ {arg13 ""}
+ {arg14 ""}
+} {
+ Starts a form fieldset by appending a fieldset tag. Fieldset closes when form is closed or another fieldset defined in same form.
+} {
+ # use upvar to set form content, set/change defaults
+ # __qf_arr contains last attribute values of tag, indexed by {tag}_attribute, __form_last_id is in __qf_arr(form_id)
+ upvar 1 __form_ids_list __form_ids_list
+ upvar 1 __form_arr __form_arr
+ upvar 1 __qf_remember_attributes __qf_remember_attributes
+ upvar 1 __qf_arr __qf_arr
+ upvar 1 __form_ids_fieldset_open_list __form_ids_fieldset_open_list
+
+ # if proc was passed a list of parameters, parse
+ if { [llength $arg1] > 1 && [llength $arg2] == 0 } {
+ set arg1_list $arg1
+ set lposition 1
+ foreach arg $arg1_list {
+ set arg${lposition} $arg
+ incr lposition
+ }
+ unset arg1_list
+ }
+
+ set attributes_tag_list [list align class id style title valign]
+ set attributes_full_list $attributes_tag_list
+ lappend attributes_full_list form_id
+ set arg_list [list $arg1 $arg2 $arg3 $arg4 $arg5 $arg6 $arg7 $arg8 $arg9 $arg10 $arg11 $arg12 $arg13 $arg14]
+ set attributes_list [list]
+ foreach {attribute value} $arg_list {
+ set attribute_index [lsearch -exact $attributes_full_list $attribute]
+ if { $attribute_index > -1 } {
+ set attributes_arr($attribute) $value
+ if { [lsearch -exact $attributes_tag_list $attribute] > -1 } {
+ lappend attributes_list $attribute
+ }
+ } elseif { $value eq "" } {
+ # do nothing
+ } else {
+ ns_log Error "qf_fieldset: $attribute is not a valid attribute. invoke with attribute value pairs. Separate each with a space."
+ ad_script_abort
+ }
+ }
+
+ if { ![info exists __qf_remember_attributes] } {
+ ns_log Error "qf_fieldset: invoked before qf_form or used in a different namespace than qf_form.."
+ ad_script_abort
+ }
+ if { ![info exists __form_ids_list] } {
+ ns_log Error "qf_fieldset: invoked before qf_form or used in a different namespace than qf_form.."
+ ad_script_abort
+ }
+ # default to last modified form_id
+ set form_id_exists [info exists attributes_arr(form_id)]
+ if { $form_id_exists == 0 || ( $form_id_exists == 1 && $attributes_arr(form_id) eq "" ) } {
+ set attributes_arr(form_id) $__qf_arr(form_id)
+ }
+ if { [lsearch $__form_ids_list $attributes_arr(form_id)] == -1 } {
+ ns_log Error "qf_fieldset: unknown form_id $attributes_arr(form_id)"
+ ad_script_abort
+ }
+
+ # use previous tag attribute values?
+ if { $__qf_remember_attributes } {
+ foreach attribute $attributes_list {
+ if { $attribute ne "id" && ![info exists attributes_arr($attribute)] && [info exists __qf_arr(fieldset_$attribute)] } {
+ set attributes_arr($attribute) $__qf_arr(form_$attribute)
+ }
+ }
+ }
+
+ # prepare attributes to process
+ set tag_attributes_list [list]
+ foreach attribute $attributes_list {
+ set __qf_arr(fieldset_$attribute) $attributes_arr($attribute)
+ lappend tag_attributes_list $attribute $attributes_arr($attribute)
+ }
+ set tag_html ""
+ set previous_fs 0
+ # first close any existing fieldset tag with form_id
+ set __fieldset_open_list_exists [info exists __form_ids_fieldset_open_list]
+ if { $__fieldset_open_list_exists } {
+ if { [lsearch $__form_ids_fieldset_open_list $attributes_arr(form_id)] > -1 } {
+ append tag_html "</fieldset>\n"
+ set previous_fs 1
+ }
+ }
+ append tag_html "<fieldset[qf_insert_attributes $tag_attributes_list]>"
+
+ # set results __form_ids_fieldset_open_list
+ if { $previous_fs } {
+ # no changes needed, "fieldset open" already indicated
+ } else {
+ if { $__fieldset_open_list_exists } {
+ lappend __form_ids_fieldset_open_list $attributes_arr(form_id)
+ } else {
+ set __form_ids_fieldset_open_list [list $attributes_arr(form_id)]
+ }
+ }
+ # set results __form_arr, we checked form_id above.
+ append __form_arr($attributes_arr(form_id)) "$tag_html\n"
+}
+
+ad_proc -public qf_textarea {
+ {arg1 ""}
+ {arg2 ""}
+ {arg3 ""}
+ {arg4 ""}
+ {arg5 ""}
+ {arg6 ""}
+ {arg7 ""}
+ {arg8 ""}
+ {arg9 ""}
+ {arg10 ""}
+ {arg11 ""}
+ {arg12 ""}
+ {arg13 ""}
+ {arg14 ""}
+ {arg15 ""}
+ {arg16 ""}
+ {arg17 ""}
+ {arg18 ""}
+ {arg19 ""}
+ {arg20 ""}
+ {arg21 ""}
+ {arg22 ""}
+ {arg23 ""}
+ {arg24 ""}
+ {arg25 ""}
+ {arg26 ""}
+ {arg27 ""}
+ {arg28 ""}
+ {arg29 ""}
+ {arg30 ""}
+} {
+ Creates a form textarea tag, supplying attributes where nonempty values are supplied.
+ Attribute "label" places a label tag just before textarea tag, instead of wrapping around textarea
+ in order to facilitate practical alignment variations between label and textarea.
+ To remove label tag, pass label attribute with empty string value.
+} {
+ # use upvar to set form content, set/change defaults
+ # __qf_arr contains last attribute values of tag, indexed by {tag}_attribute, __form_last_id is in __qf_arr(form_id)
+ upvar 1 __form_ids_list __form_ids_list
+ upvar 1 __form_arr __form_arr
+ upvar 1 __qf_remember_attributes __qf_remember_attributes
+ upvar 1 __qf_arr __qf_arr
+ upvar 1 __form_ids_fieldset_open_list __form_ids_fieldset_open_list
+
+ # if proc was passed a list of parameters, parse
+ if { [llength $arg1] > 1 && [llength $arg2] == 0 } {
+ set arg1_list $arg1
+ set lposition 1
+ foreach arg $arg1_list {
+ set arg${lposition} $arg
+ incr lposition
+ }
+ unset arg1_list
+ }
+
+ set attributes_tag_list [list accesskey align class cols id name readonly rows style tabindex title wrap]
+ set attributes_full_list $attributes_tag_list
+ lappend attributes_full_list value label form_id
+ set arg_list [list $arg1 $arg2 $arg3 $arg4 $arg5 $arg6 $arg7 $arg8 $arg9 $arg10 $arg11 $arg12 $arg13 $arg14 $arg15 $arg16 $arg17 $arg18 $arg19 $arg20 $arg21 $arg22 $arg23 $arg24 $arg25 $arg26 $arg27 $arg28 $arg29 $arg30]
+ set attributes_list [list]
+ foreach {attribute value} $arg_list {
+ set attribute_index [lsearch -exact $attributes_full_list $attribute]
+ if { $attribute_index > -1 } {
+ set attributes_arr($attribute) $value
+ if { [lsearch -exact $attributes_tag_list $attribute ] > -1 } {
+ lappend attributes_list $attribute
+ }
+ } elseif { $value eq "" } {
+ # do nothing
+ } else {
+ ns_log Error "qf_textarea: $attribute is not a valid attribute. invoke with attribute value pairs. Separate each with a space."
+ ad_script_abort
+ }
+ }
+
+ if { ![info exists __qf_remember_attributes] } {
+ ns_log Error "qf_textarea: invoked before qf_form or used in a different namespace than qf_form.."
+ ad_script_abort
+ }
+ if { ![info exists __form_ids_list] } {
+ ns_log Error "qf_textarea: invoked before qf_form or used in a different namespace than qf_form.."
+ ad_script_abort
+ }
+ # default to last modified form_id
+ set form_id_exists [info exists attributes_arr(form_id)]
+ if { $form_id_exists == 0 || ( $form_id_exists == 1 && $attributes_arr(form_id) eq "" ) } {
+ set attributes_arr(form_id) $__qf_arr(form_id)
+ }
+ if { [lsearch $__form_ids_list $attributes_arr(form_id)] == -1 } {
+ ns_log Error "qf_textarea: unknown form_id $attributes_arr(form_id)"
+ ad_script_abort
+ }
+
+ # use previous tag attribute values?
+ if { $__qf_remember_attributes } {
+ foreach attribute $attributes_list {
+ if { $attribute ne "id" && ![info exists attributes_arr($attribute)] && [info exists __qf_arr(textarea_$attribute)] } {
+ set attributes_arr($attribute) $__qf_arr(textarea_$attribute)
+ }
+ }
+ }
+
+ # value defaults to blank
+ if { ![info exists attributes_arr(value) ] } {
+ set attributes_arr(value) ""
+ lappend attributes_list "value"
+ }
+
+ # id defalts to form_id+name if label exists..
+ if { [info exists attributes_arr(label)] && ![info exists attributes_arr(id)] && [info exists attributes_arr(name)] } {
+ set attributes_arr(id) "${attributes_arr(form_id)}-${attributes_arr(name)}"
+ lappend attributes_list id
+ }
+
+ # prepare attributes to process
+ set tag_attributes_list [list]
+ foreach attribute $attributes_list {
+ set __qf_arr(textarea_$attribute) $attributes_arr($attribute)
+ lappend tag_attributes_list $attribute $attributes_arr($attribute)
+ }
+
+ # by default, wrap the input with a label tag for better UI
+ if { [info exists attributes_arr(id) ] && [info exists attributes_arr(label)] && $attributes_arr(label) ne "" } {
+ set tag_html "<label for=\"${attributes_arr(id)}\">${attributes_arr(label)}</label><textarea[qf_insert_attributes $tag_attributes_list]>${attributes_arr(value)}</textarea>"
+ } else {
+ set tag_html "<textarea[qf_insert_attributes $tag_attributes_list]>${attributes_arr(value)}</textarea>"
+ }
+ # set results __form_arr, we checked form_id above.
+ append __form_arr($attributes_arr(form_id)) "${tag_html}\n"
+
+}
+
+ad_proc -public qf_select {
+ {arg1 ""}
+ {arg2 ""}
+ {arg3 ""}
+ {arg4 ""}
+ {arg5 ""}
+ {arg6 ""}
+ {arg7 ""}
+ {arg8 ""}
+ {arg9 ""}
+ {arg10 ""}
+ {arg11 ""}
+ {arg12 ""}
+ {arg13 ""}
+ {arg14 ""}
+ {arg15 ""}
+ {arg16 ""}
+ {arg17 ""}
+ {arg18 ""}
+ {arg19 ""}
+ {arg20 ""}
+ {arg21 ""}
+ {arg22 ""}
+ {arg23 ""}
+ {arg24 ""}
+ {arg25 ""}
+ {arg26 ""}
+ {arg27 ""}
+ {arg28 ""}
+} {
+ Creates a SELECT tag with nested OPTIONS, supplying necessary attributes where nonempty values are supplied. Set "multiple" to 1 to activate multiple attribute.
+ The argument for the "value" attribute is a list_of_lists passed to qf_options, where the list_of_lists represents a list of OPTION tag attribute/value pairs.
+ Alternate to passing the "value" attribute, you can pass pure html containing literal Option tags as "value_html"
+} {
+ # use upvar to set form content, set/change defaults
+ # __qf_arr contains last attribute values of tag, indexed by {tag}_attribute, __form_last_id is in __qf_arr(form_id)
+ upvar 1 __form_ids_list __form_ids_list
+ upvar 1 __form_arr __form_arr
+ upvar 1 __qf_remember_attributes __qf_remember_attributes
+ upvar 1 __qf_arr __qf_arr
+ upvar 1 __form_ids_select_open_list __form_ids_select_open_list
+
+ # if proc was passed a list of parameters, parse
+ if { [llength $arg1] > 1 && [llength $arg2] == 0 } {
+ set arg1_list $arg1
+ set lposition 1
+ foreach arg $arg1_list {
+ set arg${lposition} $arg
+ incr lposition
+ }
+ unset arg1_list
+ }
+
+ set attributes_tag_list [list accesskey align class cols id name readonly rows style tabindex title wrap]
+ set attributes_full_list $attributes_tag_list
+ lappend attributes_full_list value form_id value_html multiple
+ set arg_list [list $arg1 $arg2 $arg3 $arg4 $arg5 $arg6 $arg7 $arg8 $arg9 $arg10 $arg11 $arg12 $arg13 $arg14 $arg15 $arg16 $arg17 $arg18 $arg19 $arg20 $arg21 $arg22 $arg23 $arg24 $arg25 $arg26 $arg27 $arg28]
+ set attributes_list [list]
+ foreach {attribute value} $arg_list {
+ set attribute_index [lsearch -exact $attributes_full_list $attribute]
+ if { $attribute_index > -1 } {
+ set attributes_arr($attribute) $value
+ if { [lsearch -exact $attributes_tag_list $attribute] > -1 } {
+ lappend attributes_list $attribute
+ }
+ } elseif { $value eq "" } {
+ # do nothing
+ } else {
+ ns_log Error "qf_select: [ad_quotehtml [string range $attribute 0 15]] is not a valid attribute. invoke with attribute value pairs. Separate each with a space."
+ ad_script_abort
+ }
+ }
+
+ if { ![info exists __qf_remember_attributes] } {
+ ns_log Error "qf_select: invoked before qf_form or used in a different namespace than qf_form.."
+ ad_script_abort
+ }
+ if { ![info exists __form_ids_list] } {
+ ns_log Error "qf_select: invoked before qf_form or used in a different namespace than qf_form.."
+ ad_script_abort
+ }
+ # default to last modified form_id
+ if { ![info exists attributes_arr(form_id)] || $attributes_arr(form_id) eq "" } {
+ set attributes_arr(form_id) $__qf_arr(form_id)
+ }
+ if { [lsearch $__form_ids_list $attributes_arr(form_id)] == -1 } {
+ ns_log Error "qf_select: unknown form_id $attributes_arr(form_id)"
+ ad_script_abort
+ }
+
+ # use previous tag attribute values?
+ if { $__qf_remember_attributes } {
+ foreach attribute $attributes_list {
+ if { $attribute ne "id" && ![info exists attributes_arr($attribute)] && [info exists __qf_arr(select_$attribute)] } {
+ set attributes_arr($attribute) $__qf_arr(select_$attribute)
+ }
+ }
+ }
+
+ # prepare attributes to process
+ set tag_attributes_list [list]
+ foreach attribute $attributes_list {
+ set __qf_arr(select_$attribute) $attributes_arr($attribute)
+ lappend tag_attributes_list $attribute $attributes_arr($attribute)
+ }
+
+ set tag_html ""
+ ## auto closing the select tag has been debrecated because qf_choice and qf_choicesexists.
+ # TO add this feature requires checking other input tags etc too.
+ # This code will be ignored for now, but left in place for future expansion.
+ set previous_select 0
+ # first close any existing selects tag with form_id
+ set __select_open_list_exists [info exists __form_ids_select_open_list]
+ if { $__select_open_list_exists } {
+ if { [lsearch $__form_ids_select_open_list $attributes_arr(form_id)] > -1 } {
+# append tag_html "</select>\n"
+ set previous_select 1
+ }
+ }
+ # set results __form_ids_select_open_list
+ if { $previous_select } {
+ # no changes needed, "select open" already indicated
+ } else {
+ if { $__select_open_list_exists } {
+ lappend __form_ids_select_open_list $attributes_arr(form_id)
+ } else {
+ set __form_ids_select_open_list [list $attributes_arr(form_id)]
+ }
+ }
+
+ # add options tag
+ if { [info exists attributes_arr(value_html)] } {
+ set value_list_html $attributes_arr(value_html)
+ } else {
+ set value_list_html ""
+ }
+ if { [info exists attributes_arr(value)] } {
+ append value_list_html [qf_options $attributes_arr(value)]
+
+ }
+
+ append tag_html "<select[qf_insert_attributes $tag_attributes_list]>$value_list_html</select>"
+ # set results __form_arr, we checked form_id above.
+ append __form_arr($attributes_arr(form_id)) "${tag_html}\n"
+
+}
+
+ad_proc -private qf_options {
+ {options_list_of_lists ""}
+} {
+ Returns the sequence of options tags usually associated with SELECT tag.
+ Does not append to an open form. These results are usually passed to qf_select that appends an open form.
+ Option tags are added in sequential order. A blank list in a list_of_lists is ignored.
+ To add a blank option, include the value attribute with a blank/empty value;
+ The option tag will wrap an attribute called "name".
+ To indicate "SELECTED" attribute, include the attribute "selected" with the paired value of 1.
+} {
+ # options_list is expected to be a list like this:
+ # \[list \[list attribute1 value attribute2 value attribute3 value attribute4 value attribute5 value...\] \[list {second option tag attribute-value pairs} etc\] \]
+
+ # for this proc, we need to check the individual options for each OPTION tag, to provide the most flexibility.
+ set list_length [llength $options_list_of_lists]
+ # is this a list of lists, or just a list (1 list of list)
+ # test the second row to see if it has multiple list members
+ set multiple_option_tags_p [expr { [llength [lindex $options_list_of_lists 1] ] > 1 } ]
+ if { $list_length > 1 && $multiple_option_tags_p == 0 } {
+ # options_list is malformed, by providing only a list, not list of lists, adjust it:
+ set options_list_of_lists [list $options_list_of_lists]
+ }
+
+ set options_html ""
+ foreach option_tag_attribute_list $options_list_of_lists {
+ append options_html [qf_option $option_tag_attribute_list]
+ }
+ return $options_html
+}
+
+ad_proc -private qf_option {
+ {option_attributes_list ""}
+} {
+ returns an OPTION tag usually associated with SELECT tag. Does not append to an open form. These results are usually passed to qf_select that appends an open form.
+ Creates only one option tag. For multiple OPTION tags, see qf_options
+ To add a blank attribute, include attribute with a blank/empty value;
+ The option tag will wrap an attribute called "name".
+ To indicate "SELECTED" or "DISABLED" attribute, include the attribute ("selected" or "disabled") with the paired value of 1.
+} {
+ set attributes_tag_list [list class dir disabled id label lang language selected style title value]
+ set attributes_full_list $attributes_tag_list
+ lappend attributes_full_list label name
+ set arg_list $option_attributes_list
+ set attributes_list [list]
+ foreach {attribute value} $arg_list {
+ set attribute_index [lsearch -exact $attributes_full_list $attribute]
+ if { $attribute_index > -1 } {
+ set attributes_arr($attribute) $value
+ if { [lsearch -exact $attributes_tag_list $attribute] > -1 } {
+ lappend attributes_list $attribute
+ }
+ } elseif { $value eq "" } {
+ # do nothing
+ } else {
+ ns_log Error "qf_options: $attribute is not a valid attribute. invoke with attribute value pairs. Separate each with a space."
+ ad_script_abort
+ }
+ }
+
+ # prepare attributes to process
+ set tag_attributes_list [list]
+ foreach attribute $attributes_list {
+ if { $attribute ne "selected" && $attribute ne "disabled" && $attribute ne "checked" } {
+ lappend tag_attributes_list $attribute $attributes_arr($attribute)
+ }
+ }
+ if { [info exists attributes_arr(label)] } {
+ set name_html $attributes_arr(label)
+ } elseif { [info exists attributes_arr(name)] } {
+ set name_html $attributes_arr(name)
+ } elseif { [info exists attributes_arr(value)] } {
+ set name_html $attributes_arr(value)
+ } else {
+ set name_html ""
+ }
+ if { [info exists attributes_arr(checked)] && ![info exists attributes_arr(selected)] } {
+ set attributes_arr(selected) "1"
+ }
+ if { ([info exists attributes_arr(selected)] && $attributes_arr(selected) eq "1") && $attributes_arr(selected) eq "1" } {
+ set option_html "<option[qf_insert_attributes $tag_attributes_list] selected>$name_html</option>\n"
+ } elseif { [info exists attributes_arr(disabled)] && $attributes_arr(disabled) eq "1" } {
+ set option_html "<option[qf_insert_attributes $tag_attributes_list] disabled>$name_html</option>\n"
+ } else {
+ set option_html "<option[qf_insert_attributes $tag_attributes_list]>$name_html</option>\n"
+ }
+ return $option_html
+}
+
+
+ad_proc -public qf_close {
+ {arg1 ""}
+ {arg2 ""}
+} {
+ closes a form by appending a close form tag (and fieldset tag if any are open). if id supplied, only closes that referenced form and any fieldsets associated with it.
+} {
+ # use upvar to set form content, set/change defaults
+ upvar 1 __form_ids_list __form_ids_list
+ upvar 1 __form_arr __form_arr
+ upvar 1 __form_ids_open_list __form_ids_open_list
+ upvar 1 __form_ids_fieldset_open_list __form_ids_fieldset_open_list
+
+ set attributes_full_list [list form_id]
+ set arg_list [list $arg1 $arg2]
+ set attributes_list [list]
+ foreach {attribute value} $arg_list {
+ set attribute_index [lsearch -exact $attributes_full_list $attribute]
+ if { $attribute_index > -1 } {
+ set attributes_arr($attribute) $value
+ lappend attributes_list $attribute
+ } elseif { $value eq "" } {
+ # do nothing
+ } else {
+ ns_log Error "qf_close: $attribute is not a valid attribute. invoke with attribute value pairs. Separate each with a space."
+ ad_script_abort
+ }
+ }
+
+ if { ![info exists __form_ids_list] } {
+ ns_log Error "qf_close: invoked before qf_form or used in a different namespace than qf_form.."
+ ad_script_abort
+ }
+ # default to all open form ids
+ if { ![info exists attributes_arr(form_id)] || $attributes_arr(form_id) eq "" } {
+ set attributes_arr(form_id) $__form_ids_open_list
+ if { [lsearch -exact $attributes_list form_id] == -1 } {
+ lappend attributes_list "form_id"
+ }
+ }
+ # attributes_arr(form_id) might be a list or a single value. Following loop should work either way.
+ # close chosen form_id(s)
+ set a_fieldset_exists [info exists __form_ids_fieldset_open_list]
+ foreach form_id $attributes_arr(form_id) {
+ # check if form_id is valid
+ set form_id_position [lsearch -exact $__form_ids_open_list $attributes_arr(form_id)]
+ if { $form_id_position == -1 } {
+ ns_log Warning "qf_close: unknown form_id $attributes_arr(form_id)"
+ } else {
+ if { $a_fieldset_exists } {
+ # close fieldset tag if form has an open one.
+ set form_id_fs_position [lsearch -exact $__form_ids_fieldset_open_list $form_id]
+ if { $form_id_fs_position > -1 } {
+ append __form_arr($form_id) "</fieldset>\n"
+ # remove form_id from __form_ids_fieldset_open_list
+ set __form_ids_fieldset_open_list [lreplace $__form_ids_fieldset_open_list $form_id_fs_position $form_id_fs_position]
+ }
+ }
+ # close form
+ append __form_arr($form_id) "</form>\n"
+ # remove form_id from __form_ids_open_list
+ set __form_ids_open_list [lreplace $__form_ids_open_list $form_id_position $form_id_position]
+ }
+ }
+}
+
+ad_proc -public qf_read {
+ {arg1 ""}
+ {arg2 ""}
+} {
+
+ returns the content of forms. If a form is not closed, returns the form in its partial state of completeness. If a form_id is supplied, returns the content of a specific form. Defaults to return all forms in a list.
+} {
+ # use upvar to set form content, set/change defaults
+ upvar 1 __form_ids_list __form_ids_list
+ upvar 1 __form_arr __form_arr
+
+ set attributes_full_list [list form_id]
+ set arg_list [list $arg1 $arg2]
+ set attributes_list [list]
+ foreach {attribute value} $arg_list {
+ set attribute_index [lsearch -exact $attributes_full_list $attribute]
+ if { $attribute_index > -1 } {
+ set attributes_arr($attribute) $value
+ lappend attributes_list $attribute
+ } elseif { $value eq "" } {
+ # do nothing
+ } else {
+ ns_log Error "qf_read: $attribute is not a valid attribute. invoke with attribute value pairs. Separate each with a space."
+ ad_script_abort
+ }
+ }
+
+ if { ![info exists __form_ids_list] } {
+ ns_log Error "qf_read: invoked before qf_form or used in a different namespace than qf_form.."
+ ad_script_abort
+ }
+ # normalize code using id instead of form_id
+ if { [info exists attributes_arr(form_id)] } {
+ set attributes_arr(id) $attributes_arr(form_id)
+ unset attributes_arr(form_id)
+ }
+ # defaults to all form ids
+ set form_id_exists [info exists attributes_arr(id)]
+ if { $form_id_exists == 0 || ( $form_id_exists == 1 && $attributes_arr(id) eq "" ) } {
+ # note, attributes_arr(id) might become a list or a scalar..
+ if { [llength $__form_ids_list ] == 1 } {
+ set specified_1 1
+ set attributes_arr(id) [lindex $__form_ids_list 0]
+ } else {
+ set specified_1 0
+ set attributes_arr(id) $__form_ids_list
+ }
+ } else {
+ set specified_1 1
+ }
+
+ if { $specified_1 } {
+ # a form specified in argument
+ if { ![info exists __form_arr($attributes_arr(id)) ] } {
+ ns_log Warning "qf_read: unknown form_id $attributes_arr(id)"
+ } else {
+ set form_s $__form_arr($attributes_arr(id))
+ }
+ } else {
+ set forms_list [list]
+ foreach form_id $attributes_arr(id) {
+ # check if form_id is valid
+ set form_id_position [lsearch $__form_ids_list $form_id]
+ if { $form_id_position == -1 } {
+ ns_log Warning "qf_read: unknown form_id $form_id"
+ } else {
+ lappend forms_list $__form_arr($form_id)
+ }
+ }
+ set form_s $forms_list
+ }
+ return $form_s
+}
+
+
+ad_proc -public qf_input {
+ {arg1 ""}
+ {arg2 ""}
+ {arg3 ""}
+ {arg4 ""}
+ {arg5 ""}
+ {arg6 ""}
+ {arg7 ""}
+ {arg8 ""}
+ {arg9 ""}
+ {arg10 ""}
+ {arg11 ""}
+ {arg12 ""}
+ {arg13 ""}
+ {arg14 ""}
+ {arg15 ""}
+ {arg16 ""}
+ {arg17 ""}
+ {arg18 ""}
+ {arg19 ""}
+ {arg20 ""}
+ {arg21 ""}
+ {arg22 ""}
+ {arg23 ""}
+ {arg24 ""}
+ {arg25 ""}
+ {arg26 ""}
+ {arg27 ""}
+ {arg28 ""}
+ {arg29 ""}
+ {arg30 ""}
+ {arg31 ""}
+ {arg32 ""}
+} {
+ creates a form input tag, supplying attributes where nonempty values are supplied. when using CHECKED, set the attribute to 1.
+ allowed attributes: type accesskey align alt border checked class id maxlength name readonly size src tabindex value title.
+ other allowed: form_id label. label is used to wrap the input tag with a label tag containing a label that is associated with the input.
+ checkbox and radio inputs present label after input tag, other inputs are preceeded by label. Omit label attribute to not use this feature. Attribute title is associated with label.
+} {
+ # use upvar to set form content, set/change defaults
+ # __qf_arr contains last attribute values of tag, indexed by {tag}_attribute, __form_last_id is in __qf_arr(form_id)
+ upvar 1 __form_ids_list __form_ids_list
+ upvar 1 __form_arr __form_arr
+ upvar 1 __qf_remember_attributes __qf_remember_attributes
+ upvar 1 __qf_arr __qf_arr
+ upvar 1 __form_ids_fieldset_open_list __form_ids_fieldset_open_list
+
+ # if proc was passed a list of parameters, parse
+ if { [llength $arg1] > 1 && [llength $arg2] == 0 } {
+ set arg1_list $arg1
+ set lposition 1
+ foreach arg $arg1_list {
+ set arg${lposition} $arg
+ incr lposition
+ }
+ unset arg1_list
+ }
+
+ set attributes_tag_list [list type accesskey align alt border checked class id maxlength name readonly size src tabindex value]
+ set attributes_full_list $attributes_tag_list
+ lappend attributes_full_list form_id label selected title
+ set arg_list [list $arg1 $arg2 $arg3 $arg4 $arg5 $arg6 $arg7 $arg8 $arg9 $arg10 $arg11 $arg12 $arg13 $arg14 $arg15 $arg16 $arg17 $arg18 $arg19 $arg20 $arg21 $arg22 $arg23 $arg24 $arg25 $arg26 $arg27 $arg28 $arg29 $arg30 $arg31 $arg32]
+
+ set attributes_list [list]
+ foreach {attribute value} $arg_list {
+ set attribute_index [lsearch -exact $attributes_full_list $attribute]
+ if { $attribute_index > -1 } {
+ set attributes_arr($attribute) $value
+ if { [lsearch -exact $attributes_tag_list $attribute] > -1 } {
+ lappend attributes_list $attribute
+ }
+ } elseif { $value eq "" } {
+ # do nothing
+ } else {
+ ns_log Error "qf_input: $attribute is not a valid attribute. invoke with attribute value pairs. Separate each with a space."
+ }
+ }
+
+ if { ![info exists __qf_remember_attributes] } {
+ ns_log Notice "qf_input(L801): invoked before qf_form or used in a different namespace than qf_form.."
+ set __qf_remember_attributes 0
+ }
+ if { ![info exists __form_ids_list] } {
+ ns_log Warning "qf_input:(L805) invoked before qf_form or used in a different namespace than qf_form.."
+ set __form_ids_list [list [random]]
+ set __qf_arr(form_id) $__form_ids_list
+ }
+ # default to last modified form_id
+ if { ![info exists attributes_arr(form_id)] || $attributes_arr(form_id) eq "" } {
+ set attributes_arr(form_id) $__qf_arr(form_id)
+ }
+ if { [lsearch $__form_ids_list $attributes_arr(form_id)] == -1 } {
+ ns_log Error "qf_input: unknown form_id $attributes_arr(form_id)"
+ ad_script_abort
+ }
+
+ # use previous tag attribute values?
+ if { $__qf_remember_attributes } {
+ foreach attribute $attributes_list {
+ if { $attribute ne "id" && $attribute ne "value" && ![info exists attributes_arr($attribute)] && [info exists __qf_arr(input_$attribute)] } {
+ set attributes_arr($attribute) $__qf_arr(input_$attribute)
+ }
+ }
+ }
+
+ # provide a blank value by default
+ if { ![info exists attributes_arr(value)] } {
+ set attributes_arr(value) ""
+ }
+ # convert a "selected" parameter to checked
+ if { ([info exists attributes_arr(selected)] && $attributes_arr(selected) eq "1") && ![info exists attributes_arr(checked)] } {
+ set attributes_arr(checked) $attributes_arr(selected)
+ lappend attributes_list "checked"
+ }
+
+ # by default, wrap the input with a label tag for better UI, part 1
+ if { [info exists attributes_arr(label)] && [info exists attributes_arr(type) ] && $attributes_arr(type) ne "hidden" } {
+ if { ![info exists attributes_arr(id) ] } {
+ set attributes_arr(id) $attributes_arr(name)
+ append attributes_arr(id) "-[string range [clock clicks -milliseconds] end-3 end]-[string range [random ] 2 end]"
+ lappend attributes_list "id"
+ }
+ if { [info exists attributes_arr(title) ] } {
+ set label_title $attributes_arr(title)
+ unset attributes_arr(title)
+ }
+ }
+ # prepare attributes to process
+ set tag_attributes_list [list]
+ set tag_suffix ""
+ foreach attribute $attributes_list {
+ set __qf_arr(input_$attribute) $attributes_arr($attribute)
+ if { $attribute ne "checked" && $attribute ne "disabled" } {
+ lappend tag_attributes_list $attribute $attributes_arr($attribute)
+ } else {
+ set tag_suffix " ${attribute}"
+ # set to checked or disabled
+ }
+ }
+
+ # by default, wrap the input with a label tag for better UI, part 2
+ if { [info exists attributes_arr(label)] && [info exists attributes_arr(type) ] && $attributes_arr(type) ne "hidden" } {
+ if { $attributes_arr(type) eq "checkbox" || $attributes_arr(type) eq "radio" } {
+ set tag_html "<label for=\"${attributes_arr(id)}\""
+ if { [info exists label_title] } {
+ append tag_html " title=\"${label_title}\""
+ }
+ append tag_html "><input[qf_insert_attributes $tag_attributes_list]${tag_suffix}>${attributes_arr(label)}</label>"
+ } else {
+ set tag_html "<label for=\"${attributes_arr(id)}\""
+ if { [info exists label_title] } {
+ append tag_html " title=\"${label_title}\""
+ }
+ append tag_html ">${attributes_arr(label)}<input[qf_insert_attributes $tag_attributes_list]></label>"
+ }
+ } else {
+ set tag_html "<input[qf_insert_attributes $tag_attributes_list]${tag_suffix}>"
+ }
+
+ # set results __form_arr, we checked form_id above.
+ append __form_arr($attributes_arr(form_id)) "${tag_html}\n"
+
+ return "${tag_html}\n"
+}
+
+ad_proc -public qf_append {
+ {arg1 ""}
+ {arg2 ""}
+ {arg3 ""}
+ {arg4 ""}
+ {arg5 ""}
+ {arg6 ""}
+} {
+ param html required
+ param form_id
+ inserts html in a form by appending supplied html. if form_id supplied, appends form with supplied form_id.
+} {
+ # use upvar to set form content, set/change defaults
+ # __qf_arr contains last attribute values of tag, indexed by {tag}_attribute, __form_last_id is in __qf_arr(form_id)
+ upvar 1 __form_ids_list __form_ids_list
+ upvar 1 __form_arr __form_arr
+ upvar 1 __qf_arr __qf_arr
+ upvar 1 __form_ids_fieldset_open_list __form_ids_fieldset_open_list
+
+ set attributes_full_list [list html form_id]
+ set arg_list [list $arg1 $arg2 $arg3 $arg4 $arg5 $arg6]
+ set attributes_list [list]
+ foreach {attribute value} $arg_list {
+ set attribute_index [lsearch -exact $attributes_full_list $attribute]
+ if { $attribute_index > -1 } {
+ set attributes_arr($attribute) $value
+ lappend attributes_list $attribute
+ } elseif { $value eq "" } {
+ # do nothing
+ } else {
+ ns_log Error "qf_append: $attribute is not a valid attribute. invoke with attribute value pairs. Separate each with a space."
+ ad_script_abort
+ }
+ }
+
+ if { ![info exists __form_ids_list] } {
+ ns_log Warning "qf_append:(L1209) invoked before qf_form or used in a different namespace than qf_form.."
+ set __form_ids_list [list [random]]
+ set __qf_arr(form_id) $__form_ids_list
+ }
+ # default to last modified form_id
+ set form_id_exists [info exists attributes_arr(form_id)]
+ if { $form_id_exists == 0 || ( $form_id_exists == 1 && $attributes_arr(form_id) eq "" ) } {
+ set attributes_arr(form_id) $__qf_arr(form_id)
+ lappend attributes_list form_id
+ }
+ if { [lsearch $__form_ids_list $attributes_arr(form_id)] == -1 } {
+ ns_log Error "qf_append: unknown form_id $attributes_arr(form_id)"
+ ad_script_abort
+ }
+ if { ![info exists attributes_arr(html)] } {
+ set attributs_arr(html) ""
+ ns_log Notice "qf_append: no argument 'html'"
+ if { [lsearch -exact $attributes_list "html"] == -1 } {
+ set attributes_arr(html) ""
+ lappend attributes_list "html"
+ }
+ }
+
+ # set results __form_arr, we checked form_id above.
+ append __form_arr($attributes_arr(form_id)) $attributes_arr(html)
+ return $attributes_arr(html)
+}
+
+ad_proc -private qf_insert_attributes {
+ args_list
+} {
+ returns args_list of tag attribute pairs (attribute,value) as html to be inserted into a tag
+} {
+ set args_html ""
+ foreach {attribute value} $args_list {
+ if { [string range $attribute 1 1] eq "-" } {
+ set $attribute [string range $attribute 1 end]
+ }
+ regsub -all -- {\"} $value {\"} value
+ append args_html " $attribute=\"$value\""
+ }
+ return $args_html
+}
+
+ad_proc -public qf_choice {
+ {arg1 ""}
+ {arg2 ""}
+ {arg3 ""}
+ {arg4 ""}
+ {arg5 ""}
+ {arg6 ""}
+ {arg7 ""}
+ {arg8 ""}
+ {arg9 ""}
+ {arg10 ""}
+ {arg11 ""}
+ {arg12 ""}
+ {arg13 ""}
+ {arg14 ""}
+ {arg15 ""}
+ {arg16 ""}
+ {arg17 ""}
+ {arg18 ""}
+ {arg19 ""}
+ {arg20 ""}
+ {arg21 ""}
+ {arg22 ""}
+ {arg23 ""}
+ {arg24 ""}
+} {
+ Returns html of a select/option bar or radio button list (where only 1 value is returned to a posted form).
+ Set "type" to "select" for select bar, or "radio" for radio buttons
+ Required attributes: name, value
+ "value" argument is a list_of_lists, each list item contains a list of attribute/value pairs for generating a radio or option/bar item.
+ "selected" is not required. Each choice is "unselected" by default. Set "selected" attribute to 1 to indicate item selected.
+ For this proc, "label" refers to the text that labels a radio buttion or select option item. If a "label" attribute/value pair is not included, The tag's value attribute is used for label as well.
+<pre>
+Example usage. This code:
+ set tag_attribute_list [list [list label " label1 " value visa1] [list label " label2 " value visa2] [list label " label3 " value visa3] ]
+ qf_choice type radio name creditcard value $tag_attribute_list
+
+Generates:
+
+"<label><input type="radio" name="creditcard" value="visa1"> label1 </label>
+ <label><input type="radio" name="creditcard" value="visa2"> label2 </label>
+ <label><input type="radio" name="creditcard" value="visa3"> label3 </label>"
+
+By switching type to select like this:
+
+ qf_choice type select name creditcard value $tag_attribute_list
+
+the code generates:
+
+"<select name="creditcard">
+<option value="visa1"> label1 </option>
+<option value="visa2"> label2 </option>
+<option value="visa3"> label3 </option>
+</select>"
+</pre>
+ <!-- < is used to prevent browser views from rendering the code presented here -->
+} {
+ # use upvar to set form content, set/change defaults
+ # __qf_arr contains last attribute values of tag, indexed by {tag}_attribute, __form_last_id is in __qf_arr(form_id)
+ upvar 1 __form_ids_list __form_ids_list
+ upvar 1 __form_arr __form_arr
+ upvar 1 __qf_remember_attributes __qf_remember_attributes
+ upvar 1 __qf_arr __qf_arr
+ upvar 1 __form_ids_select_open_list __form_ids_select_open_list
+ set attributes_select_list [list value accesskey align class cols name readonly rows style tabindex title wrap]
+ set attributes_full_list $attributes_select_list
+ lappend attributes_full_list type form_id id
+ set arg_list [list $arg1 $arg2 $arg3 $arg4 $arg5 $arg6 $arg7 $arg8 $arg9 $arg10 $arg11 $arg12 $arg13 $arg14 $arg15 $arg16 $arg17 $arg18 $arg19 $arg20 $arg21 $arg22 $arg23 $arg24]
+ set attributes_list [list]
+ set select_list [list]
+ foreach {attribute value} $arg_list {
+ set attribute_index [lsearch -exact $attributes_full_list $attribute]
+ if { $attribute_index > -1 } {
+ set attributes_arr($attribute) $value
+ lappend attributes_list $attribute
+ if { [lsearch -exact $attributes_select_list $attribute] > -1 } {
+ # create a list to pass to qf_select without it balking at unknown parameters
+ lappend select_list $attribute $value
+ }
+ } elseif { $value eq "" } {
+ # do nothing
+ } else {
+ ns_log Error "qf_choice: [string range $attribute 0 15] is not a valid attribute. invoke with attribute value pairs. Separate each with a space."
+ ad_script_abort
+ }
+ }
+ # for passing select_list, we need to pass form_id literally
+ # default to last modified form_id
+ set form_id_exists [info exists attributes_arr(form_id)]
+ if { $form_id_exists == 0 || ( $form_id_exists == 1 && $attributes_arr(form_id) eq "" ) } {
+ set attributes_arr(form_id) $__qf_arr(form_id)
+ }
+ if { [lsearch $__form_ids_list $attributes_arr(form_id)] == -1 } {
+ ns_log Error "qf_choice: unknown form_id $attributes_arr(form_id)"
+ ad_script_abort
+ }
+ lappend select_list form_id $attributes_arr(form_id)
+
+
+
+ # if attributes_arr(type) = select, then items are option tags wrapped by a select tag
+ # if attributes_arr(type) = radio, then items are input tags, wrapped in a list for now
+ # if needing to paginate radio buttons, build the radio buttons using qf_input directly.
+
+ if { $attributes_arr(type) ne "radio" } {
+ set type "select"
+ } else {
+ set type "radio"
+ }
+
+ # call qf_select if type is "select" instead of duplicating purpose of that code
+
+ if { $type eq "radio" } {
+ # create wrapping tag
+ set tag_wrapping "ul"
+ set args_html "<${tag_wrapping}"
+ foreach attribute $attributes_list {
+ # ignore proc parameters that are not tag attributes for the tag_wrapping tag
+ if { $attribute eq "id" || $attribute eq "style" || $attribute eq "class" } {
+ # quoting unquoted double quotes in attribute values, so as to not inadvertently break the tag
+ regsub -all -- {\"} $attributes_arr($attribute) {\"} attributes_arr($attribute)
+ append args_html " $attribute=\"$attributes_arr($attribute)\""
+ }
+ }
+ append args_html ">\n"
+ qf_append form_id $attributes_arr(form_id) html $args_html
+ set args_html ""
+
+ # verify this is a list of lists.
+ set list_length [llength $attributes_arr(value)]
+ # test on the second input, less chance its a special case
+ set second_input_attributes_count [llength [lindex $attributes_arr(value) 1]]
+ if { $list_length > 1 && $second_input_attributes_count < 2 } {
+ # a list was passed instead of a list of lists. Adjust..
+ set attributes_arr(value) [list $attributes_arr(value)]
+ }
+ foreach input_attributes_list $attributes_arr(value) {
+ if { [f::even_p [llength $input_attributes_list]] } {
+ array unset input_arr
+ array set input_arr $input_attributes_list
+ if { ![info exists input_arr(label)] && [info exists input_arr(value)] } {
+ set input_arr(label) $input_arr(value)
+ }
+ if { ![info exists input_arr(name)] && [info exists attributes_arr(name)] } {
+ set input_arr(name) $attributes_arr(name)
+ }
+ set input_attributes_list [array get input_arr]
+ lappend input_attributes_list form_id $attributes_arr(form_id) type radio
+ qf_append form_id $attributes_arr(form_id) html "<li>"
+ qf_input $input_attributes_list
+ qf_append form_id $attributes_arr(form_id) html "</li>"
+ } else {
+ ns_log Notice "qf_choice: list not even number of members, skipping rendering of value attribute with list: $input_attributes_list"
+ }
+ }
+ append args_html "</${tag_wrapping}>"
+ qf_append form_id $attributes_arr(form_id) html $args_html
+
+ } else {
+
+ set args_html [qf_select $select_list]
+
+ }
+ return $args_html
+}
+
+ad_proc -public qf_choices {
+ {arg1 ""}
+ {arg2 ""}
+ {arg3 ""}
+ {arg4 ""}
+ {arg5 ""}
+ {arg6 ""}
+ {arg7 ""}
+ {arg8 ""}
+ {arg9 ""}
+ {arg10 ""}
+ {arg11 ""}
+ {arg12 ""}
+ {arg13 ""}
+ {arg14 ""}
+ {arg15 ""}
+ {arg16 ""}
+ {arg17 ""}
+ {arg18 ""}
+ {arg19 ""}
+ {arg20 ""}
+ {arg21 ""}
+ {arg22 ""}
+ {arg23 ""}
+ {arg24 ""}
+ } {
+ returns html of a select multiple box or list of checkboxes (where multiple values may be sent with form post).
+ Required attributes: name, value.
+ Set "type" to "select" for multi select box, or "checkbox" for checkboxes.
+ The value of the "value" attribute is a list_of_lists, each list item contains attribute/value pairs for a radio or option/bar item.
+ If "label" not provided for tags in the list_of_lists, the value of the "value" attribute is also used for label.
+ Set "selected" attribute to 1 in the value list_of_lists to indicate item selected. Default is unselected (if selected attributed is not included, or its value not 1)..
+ } {
+ # use upvar to set form content, set/change defaults
+ # __qf_arr contains last attribute values of tag, indexed by {tag}_attribute, __form_last_id is in __qf_arr(form_id)
+ upvar 1 __form_ids_list __form_ids_list
+ upvar 1 __form_arr __form_arr
+ upvar 1 __qf_remember_attributes __qf_remember_attributes
+ upvar 1 __qf_arr __qf_arr
+ upvar 1 __form_ids_select_open_list __form_ids_select_open_list
+
+ set attributes_select_list [list value accesskey align class cols name readonly rows style tabindex title wrap]
+ set attributes_full_list $attributes_select_list
+ lappend attributes_full_list type form_id id
+ set arg_list [list $arg1 $arg2 $arg3 $arg4 $arg5 $arg6 $arg7 $arg8 $arg9 $arg10 $arg11 $arg12 $arg13 $arg14 $arg15 $arg16 $arg17 $arg18 $arg19 $arg20 $arg21 $arg22 $arg23 $arg24]
+ set attributes_list [list]
+ set select_list [list]
+ foreach {attribute value} $arg_list {
+ set attribute_index [lsearch -exact $attributes_full_list $attribute]
+ if { $attribute_index > -1 } {
+ set attributes_arr($attribute) $value
+ lappend attributes_list $attribute
+ if { [lsearch -exact $attributes_select_list $attribute ] > -1 } {
+ # create a list to pass to qf_select without it balking at unknown parameters
+ lappend select_list $attribute $value
+ }
+ } elseif { $value eq "" } {
+ # do nothing
+ } else {
+ ns_log Error "qf_choices: [string range $attribute 0 15] is not a valid attribute. invoke with attribute value pairs. Separate each with a space."
+ ad_script_abort
+ }
+ }
+
+ # for passing select_list, we need to pass form_id literally
+ # default to last modified form_id
+ set form_id_exists [info exists attributes_arr(form_id)]
+ if { $form_id_exists == 0 || ( $form_id_exists == 1 && $attributes_arr(form_id) eq "" ) } {
+ set attributes_arr(form_id) $__qf_arr(form_id)
+ }
+ if { [lsearch $__form_ids_list $attributes_arr(form_id)] == -1 } {
+ ns_log Error "qf_choice: unknown form_id $attributes_arr(form_id)"
+ ad_script_abort
+ }
+ lappend select_list form_id $attributes_arr(form_id)
+
+ # if attributes_arr(type) = select, then items are option tags wrapped by a select tag
+ # if attributes_arr(type) = checkbox, then items are input tags, wrapped in a list for now
+ # if needing to paginate checkboxes, build the checkboxes using qf_input directly.
+
+ if { $attributes_arr(type) ne "checkbox" } {
+ set type "select"
+ } else {
+ set type "checkbox"
+ }
+
+ # call qf_select if type is "select" instead of duplicating purpose of that code
+
+ if { $type eq "checkbox" } {
+ # create wrapping tag
+ set tag_wrapping "ul"
+ set args_html "<${tag_wrapping}"
+ foreach attribute $attributes_list {
+ # ignore proc parameters that are not tag attributes
+ if { $attribute eq "id" || $attribute eq "style" || $attribute eq "class" } {
+ # quoting unquoted double quotes in attribute values, so as to not inadvertently break the tag
+ regsub -all -- {\"} $attributes_arr($attribute) {\"} attributes_arr($attribute)
+ append args_html " $attribute=\"$attributes_arr($attribute)\""
+ }
+ }
+ append args_html ">\n"
+ qf_append form_id $attributes_arr(form_id) html $args_html
+ set args_html ""
+
+ # verify this is a list of lists.
+ set list_length [llength $attributes_arr(value)]
+ # test on the second input, less chance its a special case
+ set second_input_attributes_count [llength [lindex $attributes_arr(value) 1]]
+ if { $list_length > 1 && $second_input_attributes_count < 2 } {
+ # a list was passed instead of a list of lists. Adjust..
+ set attributes_arr(value) [list $attributes_arr(value)]
+ }
+
+ foreach input_attributes_list $attributes_arr(value) {
+ array unset input_arr
+ array set input_arr $input_attributes_list
+ if { ![info exists input_arr(label)] && [info exists input_arr(value)] } {
+ set input_arr(label) $input_arr(value)
+ }
+ if { ![info exists input_arr(name)] && [info exists attributes_arr(name)] } {
+ set input_arr(name) $attributes_arr(name)
+ }
+ set input_attributes_list [array get input_arr]
+ lappend input_attributes_list form_id $attributes_arr(form_id) type checkbox
+ qf_append form_id $attributes_arr(form_id) html "<li>"
+ qf_input $input_attributes_list
+ qf_append form_id $attributes_arr(form_id) html "</li>"
+ }
+ qf_append form_id $attributes_arr(form_id) html "</${tag_wrapping}>\n"
+ } else {
+ set args_html [qf_select $select_list]
+ }
+ return $args_html
+}
Index: openacs-4/packages/q-forms/www/doc/index.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/q-forms/www/doc/index.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/q-forms/www/doc/index.adp 14 Nov 2014 18:27:53 -0000 1.1
@@ -0,0 +1,77 @@
+<master>
+<property name="title">@title;noquote@</property>
+<property name="context">@context;noquote@</property>
+<h2>Q-Forms</h2>
+<pre>
+The lastest version of the code is available at the site:
+ http://github.com/dcpm/q-forms
+The development site: http://github.com/tekbasse/q-forms
+</pre>
+<h3>
+introduction
+</h3>
+<p>
+Q-Forms provides procedures for building forms dynamically in OpenACS tcl.
+It is an OpenACS service package that allows convenient building and
+interpreting of web-based forms via tcl in a web page.
+</p><p>
+Q-Forms procedures parallel html's form tags with many
+automatic defaults that remove the tedious nature of building forms
+via html or an alternate form building context, such as OpenACS form
+builder, ad_form or acs-templating.
+</p>
+<h3>
+license
+</h3>
+<pre>
+Copyright (c) 2013 Benjamin Brink
+po box 20, Marylhurst, OR 97036-0020 usa
+email: tekbasse@yahoo.com
+</pre>
+<p>
+Q-Forms is open source and published under the GNU General Public License, consistent with the OpenACS system: http://www.gnu.org/licenses/gpl.html
+</p><p>
+A local copy is available at <a href="LICENSE.html">q-forms/www/doc/LICENSE.html</a>
+</p><pre>
+ 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
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+</pre>
+<h3>
+features
+</h3>
+<ul><li>
+Low learning-curve:<ul><li>Uses tcl context.</li><li>Procedures match tags.</li><li>TCL list friendly.</li></ul>
+</li><li>
+Built-in API defaults: Takes less keystrokes to build a form than typing html manually.
+</li><li>
+Can build multiple forms concurently using Tcl file terminology.
+</li><li>
+No limitations to building dynamic forms with specialized inputs.
+</li><li>
+Form values are retrieved as a tcl array named by the programmer.
+</li><li>
+Form values are automatically quoted, a requirement of secure input handling.
+</li><li>
+Optional, automatic hash generation helps secure form transactions
+and ignores multiple posts caused from mouse double-clicks and browsing page history.
+</li><li>
+Passing multiple values of same input name can be combined as a list (instead of producing
+a form post error typical of ad_form/ad_page_contract).
+</li><li>
+html can be inserted in any form at any point during the build.
+</li><li>
+No UI javascript is used. Technologies with limited UI, cpu power, or low QOS connection can use it.
+</li><li>
+Integrates with acs-templating features.
+</li></ul>
+
Index: openacs-4/packages/q-forms/www/doc/index.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/q-forms/www/doc/index.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/q-forms/www/doc/index.tcl 14 Nov 2014 18:27:53 -0000 1.1
@@ -0,0 +1,2 @@
+set title "Documentation"
+set context [list $title]