Index: openacs-4/packages/acs-bootstrap-installer/tcl/00-proc-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-bootstrap-installer/tcl/00-proc-procs.tcl,v diff -u -r1.18 -r1.19 --- openacs-4/packages/acs-bootstrap-installer/tcl/00-proc-procs.tcl 9 Mar 2005 16:24:52 -0000 1.18 +++ openacs-4/packages/acs-bootstrap-installer/tcl/00-proc-procs.tcl 11 Mar 2005 20:12:55 -0000 1.19 @@ -87,6 +87,8 @@ set deprecated_p 0 set warn_p 0 set debug_p 0 + set callback "" + set impl "" # Loop through args, stopping at the first argument which is # not a switch. @@ -112,6 +114,20 @@ -deprecated { set deprecated_p 1 } -warn { set warn_p 1 } -debug { set debug_p 1 } + -callback { + incr i + set callback [lindex $args $i] + if { [ad_proc_valid_switch_p $callback] } { + return -code error "Missing callback name: -callback " + } + } + -impl { + incr i + set impl [lindex $args $i] + if { [ad_proc_valid_switch_p $impl] } { + return -code error "Missing implementation name: -impl " + } + } default { return -code error "Invalid switch [lindex $args $i] passed to ad_proc" } @@ -126,16 +142,51 @@ return -code error "Switch -warn can be provided to ad_proc only if -deprecated is also provided" } + if { ![string equal $impl ""] && [string equal $callback ""] } { + return -code error "A callback contract name must be specified with -callback when defining an implementation with -impl" + } + + if { [string equal $impl impl] || [string match $impl "impl::*"] } { + return -code error "Callback implementations may not be named impl" + } + + if { [string equal $callback contract] || [string match $callback "contract::*"] } { + return -code error "Callbacks may not be named contract" + } + # Now $i is set to the index of the first non-switch argument. # There must be either three or four arguments remaining. set n_args_remaining [expr { [llength $args] - $i }] - if { $n_args_remaining != 3 && $n_args_remaining != 4 } { - return -code error "Wrong number of arguments passed to ad_proc" - } - # Set up the remaining arguments. - set proc_name [lindex $args $i] + if {[string equal $callback ""]} { + # We are creating a normal proc so the proc name is an argument + if { $n_args_remaining < 3 || $n_args_remaining > 4} { + return -code error "Wrong number of arguments passed to ad_proc" + } + # Set up the remaining arguments. + set proc_name [lindex $args $i] + } else { + # We are creating a callback contract or implementation so there is + # no proc name + if { $n_args_remaining < 2 || $n_args_remaining > 3} { + return -code error "Wrong number of arguments passed to ad_proc" + } + + set callback [string trimleft $callback ::] + set proc_name ::callback::${callback} + + if {[string equal $impl ""]} { + append proc_name ::contract + } else { + append proc_name ::impl::${impl} + } + + # pretend to the rest of the proc that we were passed the proc name + incr n_args_remaining + set args [concat [list $proc_name] $args] + } + # (SDW - OpenACS). If proc_name is being defined inside a namespace, we # want to use the fully qualified name. Except for actually defining the # proc where we want to use the name as passed to us. We always set @@ -162,6 +213,21 @@ ns_log Debug "proc $proc_name_as_passed declared in namespace $parent_namespace via namespace eval; coding standard is to declare as $proc_name" } + if { ![string equal $callback ""] } { + # Do a namespace eval of each namespace to ensure it exists + set namespaces [split $proc_name ::] + set namespaces [lrange $namespaces 0 end-1] + + set curr_ns "" + foreach ns $namespaces { + if {![string equal $ns ""]} { + append curr_ns "::$ns" + namespace eval $curr_ns {} + } + } + } + + set arg_list [lindex $args [expr { $i + 1 }]] if { $n_args_remaining == 3 } { # No doc string provided. @@ -321,11 +387,27 @@ nsv_set proc_source_file $proc_name [info script] if { [string equal $code_block "-"] } { - return + if { [string equal $callback ""] } { + return + } else { + # we are creating a callback so create an empty body + set code_block { + # this is a callback which only invokes its arg parser + } + } } - if { [llength $switches] == 0 } { - uplevel [::list proc $proc_name_as_passed $arg_list $code_block] + set log_code "" + if { $warn_p } { + set log_code "ns_log Debug \"Deprecated proc $proc_name used\"\n" + } + + if { ![string equal $callback ""] && ![string equal $impl ""] } { + # We are creating a callback implementation so we invoke the + # arg parser of the contract proc + uplevel [::list proc $proc_name_as_passed args " ::callback::${callback}::contract__arg_parser\n${log_code}$code_block"] + } elseif { [llength $switches] == 0 } { + uplevel [::list proc $proc_name_as_passed $arg_list "${log_code}$code_block"] } else { set parser_code " ::upvar args args\n" @@ -383,11 +465,6 @@ ns_write "PARSER CODE:\n\n$parser_code\n\n" } - set log_code "" - if { $warn_p } { - set log_code "ns_log Debug \"Deprecated proc $proc_name used\"\n" - } - uplevel [::list proc ${proc_name_as_passed}__arg_parser {} $parser_code] uplevel [::list proc $proc_name_as_passed args " ${proc_name_as_passed}__arg_parser\n${log_code}$code_block"] } @@ -407,6 +484,8 @@ -private:boolean -deprecated:boolean -warn:boolean + {-callback ""} + {-impl ""} arg_list [doc_string] body @@ -512,6 +591,10 @@ @param deprecated specifies that the procedure should not be used. @param warn specifies that the procedure should generate a warning when invoked (requires that -deprecated also be set) + @param callback the name of the callback contract being defined or + implemented + @param impl the name of the callback implementation for the specified + contract @param arg_list the list of switches and positional parameters which can be provided to the procedure. @param [doc_string] documentation for the procedure (optional, but greatly desired). @@ -567,6 +650,115 @@ } } +ad_proc -public callback { + -catch:boolean + {-impl *} + callback + args +} { + Invoke the registered callback implementations for the given + callback. The callbacks terminate on error unless -catch + is provided. The value returned by the callback function is + determined by the return codes from the callback implementations. +

+ The return codes returned from the implmentation are treated + as follows: +

+
return -code ok or "return"
+
With a plain return, a non-empty return value will be lappended to + the list of returns from the callback function
+ +
return -code error or "error"
+
errors will simply propigate (and no value returned) unless -catch + is specified in which case the callback processing will continue but + no value will be appended to the return list for the implementation + which returned an error. +
+ +
return -code return
+
Takes the return value if the implementation returning -code return + and returns a one element list with that return value. Note that this means + if you have code which returns return -code return {x y}, + you will get {{x y}} as the return value from the callback. This is + done in order to unambiguously distinguish a pair of callbacks returning + x and y respectively from this single callback. +
+ +
return -code break
+
return the current list of returned values including this implementations + return value if non-empty
+ +
return -code continue
+
Continue processing, ignore the return value from this implementation
+ +
+ + @param callback the callback name without leading or trailing :: + + @param impl invoke a specific implemenation rather than all implementations + of the given callback + + @param catch if catch specified errors in the callback will be caught, tracebacks + logged as errors to the server log, but other callbacks called and the + list of returns still returned. If not given an error simply is passed + further on. + + @params args pass the set of arguments on to each callback + + @return list of the returns from each callback that does a normal (non-empty) return + + @see ad_proc +} { + if {$callback == ""} { + error "callback: no callback name given" + } + # see that the contract exists and call the contract for + # arg validation -- ::callback::${callback}::contract is an + # empty function that only runs the ad_proc generated arg parser. + + if {[llength [info proc ::callback::${callback}::contract]] != 1} { + error "Undefined callback $callback" + } + eval ::callback::${callback}::contract $args + + set returns {} + + set base ::callback::${callback}::impl + foreach procname [lsort [info procs ${base}::$impl]] { + set c [catch {::eval $procname $args} ret] + switch -exact $c { + 0 { # code ok + if {[llength $ret] > 0} { + lappend returns [list $ret] + } + } + 1 { # code error - either rethrow the current error or log + if {$catch_p} { + ns_log Error "callback $callback error invoking $procname: $ret\n[ad_print_stack_trace]\n" + } else { + return -code $c -errorcode $::errorCode -errorinfo $::errorInfo $ret + } + } + 2 { # code return -- end processing and return what we got back. + return [list $ret] + } + 3 { # code break -- terminate return current list of results. + if {[llength $ret] > 0} { + lappend returns [list $ret] + } + return $returns + } + 4 { # code continue -- just skip this one + } + default { + error "Callback return code unknown: $c" + } + } + } + return $returns +} + + ad_proc ad_library { doc_string } {