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 . + +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 @@ + + + + + Q-Forms + Q-Forms + f + t + f + f + + + Benjamin Brink + OpenACS Community + Provides code for building forms dynamically in tcl + Provides qf_* form bulding and interpreting procedures, especially designed for building forms dynamically. + 1 + + + + + + + + + + + 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 "\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 "" + foreach column $row_list { + append table_html " $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}" + incr column_i + } + append table_html "\n" + incr row_i + set column_i 0 + } + append table_html "\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 "
    " draft_list ] ne 1 } { + # no ol/ul tag, lets create the list container anyway + set draft_list "
      ${draft_list}" + + } else { + # ol/ul tag exists, trim garbage before list + set draft_list [string range $draft_list [string first "
        " $draft_list ] end ] + } + + if { [regsub -nocase -- {[ ]*]*>} $draft_list "
      " draft_list ] ne 1 } { + # end list tag may not exist or is not in standard form + if { [regsub -nocase -- {]*>} $draft_list "
    " 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 either? + append draft_list "
" + } + } + + # 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 "" $draft_list ] + 4} ] ] + + # simplify li tags, with a common delimiter + regsub -nocase -all -- {]*>} $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 -- {]*>} $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 -- {[ ]*]*>} $draft_list "" draft_list ] ne 1 } { + # end table tag may not exist or is not in standard form + if { [regsub -nocase -- {]*>} $draft_list "" 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 either? + append draft_list "" + } + } + + # 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 "" $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 -- {]+>} $draft_list "" draft_list + regsub -nocase -all -- {]+>} $draft_list "" draft_list + regsub -nocase -all -- {]+>} $draft_list "" draft_list + regsub -nocase -all -- {]+>} $draft_list "" draft_list + + # clean out other content junk tags + regsub -nocase -all -- {<[^luot\/\>][^\>]*>} $draft_list "" draft_list + regsub -nocase -all -- {][^\>]*>} $draft_list "" draft_list + + set counterA 0 + while { [string match -nocase "**" $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 "" $draft_list ] + set end_tr [string first "" $draft_list ] + + # make sure that the tr end tag matches the current tr tag + if { $end_tr == -1 } { + set next_start_tr [string first "" $draft_list [expr { $start_tr + 4 } ] ] + } else { + set next_start_tr [string first "" $draft_list $end_tr ] + } + + regsub -- {} $draft_list "
  • " draft_list + + if { $end_tr < $next_start_tr && $end_tr > -1 } { + regsub -- {} $draft_list " " draft_list + # common sense says we replace with
    • , but then there may be cases missing a + # and if so, we would have to insert a which would mess up the position values for use + # later on. Instead, at the end, we convert
  • to
  • 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 "" $draft_list ] + set end_td [string first "" $draft_list ] + set next_start_td [string first "" $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 "" [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 "" $draft_list ] + set end_td [string first "" $draft_list ] + set next_start_td [string first "" $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 -- {} $draft_list "" draft_list + } + + set column_separator ", " + # next column + } + + + # next row + } + + # clean up list, add
    • + regsub -all -- "
  • " $draft_list "
  • " draft_list + # change back first case + regsub -- "
  • " $draft_list "
  • " 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 -- {
  • :} $draft_list "
  • " 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 {} $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 "" + # 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 "
  • " + qf_input $input_attributes_list + qf_append form_id $attributes_arr(form_id) html "
    • " + } 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 "" + 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 "
  • " + qf_input $input_attributes_list + qf_append form_id $attributes_arr(form_id) html "
    • " + } + qf_append form_id $attributes_arr(form_id) html "\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 @@ + +@title;noquote@ +@context;noquote@ +

    Q-Forms

    +
    +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
+
    +

    +introduction +

    +

    +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. +

    +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 .
+
    +

    +features +

    +
    • +Low learning-curve:
      • Uses tcl context.
      • Procedures match tags.
      • TCL list friendly.
      +
    • +Built-in API defaults: Takes less keystrokes to build a form than typing html manually. +
    • +Can build multiple forms concurently using Tcl file terminology. +
    • +No limitations to building dynamic forms with specialized inputs. +
    • +Form values are retrieved as a tcl 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. +
    • +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). +
    • +html can be inserted in any form at any point during the build. +
    • +No UI javascript is used. Technologies with limited UI, cpu power, or low QOS connection can use it. +
    • +Integrates with acs-templating features. +
    + 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]