Index: openacs-4/packages/acs-tcl/tcl/form-processing-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/form-processing-procs.tcl,v
diff -u -N
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-tcl/tcl/form-processing-procs.tcl	12 May 2002 20:30:27 -0000	1.1
@@ -0,0 +1,419 @@
+ad_library {
+
+    Form processing utilities.
+
+    @author Don Baccus (dhogaza@pacifier.net)
+}
+
+ad_proc -public ad_form {
+    args
+} {
+    We'll document this when it works and has been committed 
+} {
+
+    ####################
+    #
+    # Parse arguments
+    #
+    ####################
+
+
+    if { [llength $args] == 0 } {
+        return -code error "No arguments to ad_form"
+    } 
+
+    set valid_args { form method action html name select_query select_query_name add_data \
+                     edit_data from_sql to_sql validate on_submit confirm_template on_request }; 
+
+    ad_arg_parser $valid_args $args
+
+    if { ![info exists form] } {
+        return -code error "No form argument to ad_form"
+    }
+
+    if { [info exists on_submit] && ([info exists add_data] || [info exists edit_data]) } {
+        return -code Error "\"on_submit\" not allowed in form with \"add_data\" or \"edit_data\""
+    }
+
+    ####################
+    #
+    # Step 1: Parse the form specification
+    #
+    ####################
+    # BASIC STUFF:
+    # list af_element_names                                list of form elements
+    # array af_element_parameters($element_name:$flag:):   contains a list of the parameters for an element
+
+    set af_element_names [list]
+
+    array set af_element_parameters [list]
+
+    foreach element $form {
+        set element_name_part [lindex $element 0]
+
+        # This can easily be generalized if we add more embeddable form commands ...
+
+        if { [string equal $element_name_part "-section"] } {
+            lappend af_element_names "[list "-section" [lindex $element 1]]"
+        } else {
+            if { ![regexp {^([^ \t:]+)(?::([a-zA-Z0-9_,(|)]*))?$} $element_name_part match element_name flags] } {
+                return -code error "Form element '$element_name_part' doesn't have the right format. It must be var\[:flag\[,flag ...\]\]"
+            }
+
+            lappend af_element_names $element_name
+            set af_extra_args($element_name) [lrange $element 1 end]
+            set pre_flag_list [split [string tolower $flags] ,]
+            set af_flag_list($element_name) [list]
+
+            # find parameterized flags.  We only allow one parameter.
+            foreach flag $pre_flag_list {
+                set af_element_parameters($element_name:$flag) [list]
+                set left_paren [string first "(" $flag]
+                if { $left_paren != -1 } {
+                    if { ![string equal [string index $flag end] ")"] } {
+                        return -code error "Missing or misplaced end parenthesis for flag '$flag' on argument '$element_name'"
+                    }
+                    set flag_stem [string range $flag 0 [expr $left_paren - 1]]
+                    lappend af_element_parameters($element_name:$flag_stem) [string range $flag [expr $left_paren + 1] [expr [string length $flag]-2]]
+                    lappend af_flag_list($element_name) $flag_stem
+                } else {
+                    lappend af_flag_list($element_name) $flag
+                }
+            }
+        }
+    }
+
+    # Check the validation block for boneheaded errors if it exists
+
+    set af_validate_names [list]
+    if { [info exists validate] } {
+        foreach validate_element $validate {
+            if { [llength $validate_element] != 3 } {
+                return -code error "Validate block must have three arguments: element name, expression, error message"
+            }
+
+	    if { [lsearch $af_element_names [lindex $validate_element 0]] == -1 } {
+	        return -code error "Element \"[lindex $validate_element 0]\" is not a form element"
+            }
+
+	    if { [lsearch $af_validate_names [lindex $validate_element 0]] != -1 } {
+	        return -code error "Element \"[lindex $validate_element 0]\" appears in the validation block twice"
+            }
+	}
+    }
+
+    # Create the form
+
+    if { [info exists name] } {
+        set form_name $name
+    } else {
+        set form_name [file rootname [lindex [ad_conn urlv] end]]
+    }
+
+    set create_command [list template::form create $form_name]
+
+    if { [info exists action] } {
+        lappend create_command "-action" $action
+    }
+
+    if { [info exists method] } {
+        lappend create_command "-method" $method
+    }
+
+    eval $create_command
+
+    template::element create $form_name __confirmed_p -datatype integer -widget hidden -value 0
+
+    foreach element_name $af_element_names {
+        if { [llength $element_name] == 2 } {
+            switch [string range [lindex $element_name 0] 1 end] {
+                section { template::form section $form_name [lindex $element_name 1] }
+            }
+        } else {
+            set form_command [list template::element create $form_name $element_name]
+            foreach flag $af_flag_list($element_name) {
+                switch $flag {
+
+                    key {
+                        if { [info exists key_name] } {
+                            return -code error "element $element_name: a form can only declare one key"
+                        }
+                        set key_name $element_name
+                        if { ![empty_string_p $af_element_parameters($element_name:key)] } {
+                            if { [info exists sequence_name] } {
+                                return -code error "element $element_name: duplicate sequence"
+                            }
+                            set sequence_name $af_element_parameters($element_name:key)
+                        }
+                        lappend form_command "-datatype" "integer" "-widget" "hidden"
+                        template::element create $form_name __key_signature -datatype text -widget hidden -value ""
+                        template::element create $form_name __add_p -datatype integer -widget hidden -value 0
+                    }
+
+                    optional {
+                        if { ![empty_string_p $af_element_parameters($element_name:$flag)] } {
+                            return -code error "element $element_name: $flag attribute can not have a parameter"
+                        }
+                        lappend form_command "-$flag"
+                    }
+
+                    from_sql -
+                    to_sql -
+                    to_html {
+                        if { [empty_string_p $af_element_parameters($element_name:$flag)] } {
+                            return -code error "element $element_name: \"$flag\" attribute must have a parameter"
+                        }
+                        set name af_$flag
+                        append name "($element_name)"
+                        if { [info exists $name] } {
+                            return -code error "element $element_name: \"$flag\" appears twice"
+                        }
+                        set $name $af_element_parameters($element_name:$flag)
+                    }
+
+                    default {
+                        if { [empty_string_p [info commands "::template::data::validate::$flag"]] } {
+                           return -code error "element $element_name: data type \"$flag\" is not valid"
+                        }
+                        lappend form_command "-datatype"
+                        lappend form_command $flag
+                        set af_type($element_name) $flag
+                        if { [empty_string_p $af_element_parameters($element_name:$flag)] } {
+                            if { ![empty_string_p [info command "::template::widget::$flag"]] } {
+                                lappend form_command "-widget" $flag
+                            }
+                        } else {
+                            if { [empty_string_p [info commands "::template::widget::$af_element_parameters($element_name:$flag)"]] } {
+                                return -code error "element $element_name: widget \"$af_element_parameters($element_name:$flag)\" does not exist"
+                            }
+                            lappend form_command "-widget" $af_element_parameters($element_name:$flag)
+                        }
+                    }
+                }
+            }
+              
+            foreach extra_arg $af_extra_args($element_name) {
+                lappend form_command "-[lindex $extra_arg 0]"
+                switch [lindex $extra_arg 0] {
+                    values -
+                    validate -
+                    options {
+                        lappend form_command [subst [lrange $extra_arg 1 end]]
+                    }
+                    label -
+                    format -
+                    value {
+                        if { [llength $extra_arg] > 2 || [llength $extra_arg] == 1 } {
+                            return -code error "element $element_name: \"$extra_arg\" requires exactly one argument"
+                        }
+                        lappend form_command [subst [lindex $extra_arg 1]]
+                    }
+                }
+            }
+            eval $form_command
+        }
+    }
+
+    # Check that any acquire and get_property attributes are supported by their element's datatype
+
+    foreach element_name $af_element_names {
+        if { [llength $element_name] == 1 } {
+            if { [info exists af_from_sql($element_name)] } {
+                if { [empty_string_p [info commands "::template::util::$af_type($element_name)::acquire"]] } {
+                    return -code error "\"from_sql\" not valid for type \"$af_type($element_name)\""
+                }
+            }
+            if { [info exists af_to_sql($element_name)] } {
+                if { [empty_string_p [info commands "::template::util::$af_type($element_name)::get_property"]] } {
+                    return -code error "\"to_sql\" not valid for type \"$af_type($element_name)\""
+                }
+            }
+            if { [info exists af_to_html($element_name)] } {
+                if { [empty_string_p [info commands "::template::util::$af_type($element_name)::get_property"]] } {
+                    return -code error "\"to_html\" not valid for type \"$af_type($element_name)\""
+                }
+            }
+        }
+    }
+
+    # Check for consistency if database operations are to be triggered by this form
+
+    if { [info exists sequence_name] && ![info exists key_name] } {
+        return -code error "You've supplied a sequence name no \"key_name\" parameter"
+    }
+
+    if { ([info exists from_sql] || [info exists to_sql])  && ![info exists key_name] } {
+        return -code error "You've supplied a database transaction but no \"key_name\" parameter"
+    }
+
+    if { ([info exists select_query] || [info exists select_query_name]) && \
+         ![info exists key_name] } {
+        return -code error "You've supplied a select query but no \"key_name\" parameter"
+    }
+
+    if { [info exists select_query] && [info exists select_query_name] } {
+        return -code error "You can only have one of \"select_query\" and \"select_query_name\""
+    }
+
+    # Handle a request form that triggers database operations
+
+    if { [template::form is_request $form_name] } {
+
+        # Execute the on_request block, if any.  This is normally used to query the database for
+        # menu values and similar things needed to build the form.
+
+        if { [info exists on_request] } {
+            ad_page_contract_eval uplevel 1 $on_request
+        }
+
+        if { [info exists key_name] } {
+
+            upvar $key_name $key_name
+            upvar __ad_form_values__ values
+
+            # Check to see if we're editing an existing database value
+            if { [info exists $key_name] } {
+
+                # The key exists, grab the existing values if we have an select_query clause
+
+                if { ![info exists select_query] && ![info exists select_query_name] } {
+                    return -code error "Key \"$key_name\" has the value \"[set $key_name]\" but no select_query or select_query_name clause exists"
+                }
+
+                if { [info exists select_query_name] } {
+                    set select_query ""
+                } else {
+                    set select_query_name ""
+                }
+
+                if { ![uplevel [list db_0or1row $select_query_name [join $select_query " "] -column_array __ad_form_values__]] } {
+                    return -code error "Error when selecting values"
+                }
+
+                foreach element_name $af_element_names {
+                    if { [llength $element_name] == 1 } {
+                        if { [info exists af_from_sql($element_name)] } {
+                            set values($element_name) [template::util::$af_type($element_name)::acquire \
+                                                       $af_from_sql($element_name) $values($element_name)]
+                        }
+                    }
+                }
+
+                set values($key_name) [set $key_name]
+                set values(__add_p) 0
+
+            } else {
+
+                # Make life easy for the OACS 4.5 hacker by automagically generating a value for
+                # our new database row.
+
+                if { ![info exists sequence_name] } {
+                    set sequence_name "acs_object_id_seq"
+                }
+
+                if { ![db_0or1row get_key "" -column_array values] } {
+                    return -code error "Couldn't get the next value from sequence \"$sequence_name\""
+                }
+                set values(__add_p) 1
+            }
+
+            set values(__key_signature) [ad_sign "$values($key_name):$form_name"]
+            template::form set_values $form_name values
+        }
+
+    } elseif { [template::form is_submission $form_name] } {
+
+        # Handle form submission.  We create the form values in the caller's context and execute validation
+        # expressions if they exist
+
+        uplevel [list template::form get_values $form_name]
+        upvar $key_name __key
+        upvar __key_signature __key_signature
+
+        if { [info exists key_name] && ![ad_verify_signature "$__key:$form_name" $__key_signature] } {
+            ad_return_error "Bad key signature" "Verification of the database key value failed"
+            ad_script_abort
+        }
+
+        # Execute validation expressions.  We've already done some sanity checks so know the basic structure
+        # is OK
+
+        if { [info exists validate] } {
+            foreach validate_element $validate {
+                foreach {element_name validate_expr error_message} $validate_element {
+                    if { ![template::element error_p $form_name $element_name] && \
+                          [uplevel [list expr $validate_expr]] } {
+                        template::element set_error $form_name $element_name $error_message
+                    }
+                }
+            }
+        }
+    }
+
+    if { [template::form is_valid $form_name] } {
+
+        # Run confirm and preview templates before we do final processing of the form
+
+        if { [info exists confirm_template] && ![uplevel {set __confirmed_p}] } {
+
+            # Pass the form variables to the confirm template, applying the to_html filter if present
+
+            set args [list]
+            foreach element_name $af_element_names {
+                if { [llength $element_name] == 1 } {
+                    if { [info exists af_to_html($element_name)] } {
+                        uplevel [list set $element_name \
+                            [uplevel [list template::util::$af_type($element_name)::get_property \
+                                          $af_to_html($element_name) \
+                                          [uplevel [list set $element_name]]]]]
+                    }
+                    lappend args [list $element_name [uplevel [list set $element_name]]]
+                }
+            }
+
+            # This is serious abuse of ad_return_exception_template, but hell, I wrote it so I'm entitled ...
+
+            ad_return_exception_template -status 200 -params $args $confirm_template
+
+        }
+
+        # We have three possible ways to handle the form
+
+        # 1. an on_submit block (useful for forms that don't touch the database)
+        # 2. an add_data block (when form_name:add_p is true)
+        # 3. an edit_data block (when form_name:add_p is false)
+
+        # These three are mutually exclusive, which was checked above
+
+        if { [info exists on_submit] } {
+            ad_page_contract_eval uplevel 1 $on_submit
+        } else {
+
+            # Execute our to_sql filters, if any, before passing control to the caller's
+            # add_data or edit_data blocks
+
+            foreach element_name $af_element_names {
+                if { [llength $element_name] == 1 } {
+                    if { [info exists af_to_sql($element_name)] } {
+                        uplevel [list set $element_name \
+                            [uplevel [list template::util::$af_type($element_name)::get_property \
+                                          $af_to_sql($element_name) \
+                                          [uplevel [list set $element_name]]]]]
+                    }
+                }
+            }
+
+            upvar __add_p __add_p
+
+            if { [info exists add_data] && $__add_p } {
+                ad_page_contract_eval uplevel 1 $add_data
+                template::element::set_value $form_name __add_p 0
+            } elseif { [info exists edit_data] && !$__add_p } {
+                ad_page_contract_eval uplevel 1 $edit_data
+            }
+            template::element::set_value $form_name __confirmed_p 0
+        }
+    }
+}
+
+
Index: openacs-4/packages/acs-tcl/tcl/form-processing-procs.xql
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/Attic/form-processing-procs.xql,v
diff -u -N
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-tcl/tcl/form-processing-procs.xql	12 May 2002 20:30:27 -0000	1.1
@@ -0,0 +1,10 @@
+<?xml version="1.0"?>
+<queryset>
+
+<fullquery name="ad_form.get_key">      
+   <querytext>
+      select $sequence_name.nextval as $key_name from dual
+   </querytext>
+</fullquery>
+
+</queryset>