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.42 -r1.43 --- openacs-4/packages/acs-bootstrap-installer/tcl/00-proc-procs.tcl 27 Oct 2014 16:39:06 -0000 1.42 +++ openacs-4/packages/acs-bootstrap-installer/tcl/00-proc-procs.tcl 7 Aug 2017 23:47:46 -0000 1.43 @@ -6,22 +6,25 @@ nsv_array set proc_doc [list] nsv_array set proc_source_file [list] + +# +# Safetybelt for ::acs::useNsfProc for upgrade phase to oacs-5-9 +# +if {![info exists ::acs::useNsfProc]} { + ns_log notice "use fallback value for ::acs::useNsfProc" + set ::acs::useNsfProc 0 +} +if {![info exists ::acs::useNaviServer]} { + ns_log notice "use fallback value for ::acs::useNaviServer" + set ::acs::useNaviServer [expr {[ns_info name] eq "NaviServer"}] +} + proc number_p { str } { - return [regexp {^[-+]?[0-9]*(.[0-9]+)?$} $str] + return [regexp {^[-+]?[0-9]*(.[0-9]+)?$} $str] - # Note that this will return true for empty string! - # TODO: Presumably this is by design? Probably better to use - # ad_var_type_check_number_p anyway. - # - # Note that ACS 3.2 defined number_p like this: - # - # if { $var eq "" } { - # return 0 - # } else { - # return [regexp {^-?[0-9]*\.?[0-9]*$} $var match] - # } - # - # --atp@piskorski.com, 2003/03/16 21:09 EST + # Note that this will return true for empty string! + # + # TODO: Why not use Tcl's "string is double" ? } proc empty_string_p { query_string } { @@ -46,9 +49,41 @@ proc ad_get_tcl_call_stack { { level -2 }} { set stack "" + # + # keep the previous state of ::errorInfo + # + set errorInfo $::errorInfo + for { set x [expr {[info level] + $level}] } { $x > 0 } { incr x -1 } { - append stack " called from [info level $x]\n" + set info [info level $x] + regsub -all \n $info {\\n} info + # + # In case, we have an nsf frame, add information about the + # current object and the current class to the debug output. + # + if {![catch {uplevel #$x ::nsf::current} obj] + && ![catch {uplevel #$x [list ::nsf::current class]} class] + } { + set objInfo [list $obj $class] + set info "{$objInfo} $info" + } + # + # Don't produce too long lines + # + if {[string length $info]>200} { + set arglist "" + foreach arg $info { + if {[string length $arg]>40} {set arg [string range $arg 0 40]...} + lappend arglist $arg + } + set info $arglist + } + append stack " called from $info\n" } + # + # restore previous state of ::errorInfo + # + set ::errorInfo $errorInfo return $stack } @@ -149,6 +184,11 @@ if { !$public_p && !$private_p } { set public_p 1 } + if {$public_p} { + set protection public + } else { + set protection private + } if { $warn_p && !$deprecated_p } { return -code error "Switch -warn can be provided to ad_proc only if -deprecated is also provided" @@ -175,7 +215,10 @@ set n_args_remaining [expr { [llength $args] - $i }] if {$callback eq ""} { - # We are creating a normal proc so the proc name is an argument + # + # We are creating an ordinary 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" } @@ -184,13 +227,17 @@ set proc_name [lindex $args $i] } else { if {$impl ne "" } { - # We are creating an implementation... + # + # We are creating a callback implementation + # if {$n_args_remaining != 3} { return -code error "ad_proc callback implementation must have: arguments (can be empty) docs code_body" } } if {$impl eq ""} { - # We are creating an callback contract... + # + # We are creating a contract for a callback + # if {!( $n_args_remaining == 3 || $n_args_remaining == 2 ) } { return -code error "ad_proc callback contract must have: arguments docs \[empty_code_body\]" } elseif {$n_args_remaining == 3 @@ -242,8 +289,7 @@ if { $callback ne "" } { # Do a namespace eval of each namespace to ensure it exists - set namespaces [split $proc_name ::] - set namespaces [lrange $namespaces 0 end-1] + set namespaces [lrange [split $proc_name ::] 0 end-1] set curr_ns "" foreach ns $namespaces { @@ -257,6 +303,7 @@ set arg_list [lindex $args $i+1] if { $n_args_remaining == 3 } { # No doc string provided. + #ns_log notice "missing doc string for ad_proc $proc_name ([info script])" array set doc_elements [list] set doc_elements(main) "" } else { @@ -265,8 +312,7 @@ } set code_block [lindex $args end] - if {$callback ne "" - && $impl ne "" } { + if {$callback ne "" && $impl ne "" } { if {[info exists doc_elements(see)]} { lappend doc_elements(see) "callback::${callback}::contract" } else { @@ -394,7 +440,8 @@ } } - foreach element { public_p private_p deprecated_p warn_p varargs_p arg_list switches positionals } { + set protection + foreach element { protection deprecated_p warn_p varargs_p arg_list switches positionals } { set doc_elements($element) [set $element] } foreach element { default_values flags } { @@ -428,7 +475,9 @@ return } else { # we are creating a callback so create an empty body - set code_block { # this is a callback contract which only invokes its arg parser for input validation } + set code_block { + # this is a callback contract which only invokes its arg parser for input validation + } } } @@ -438,6 +487,7 @@ } if { $callback ne "" && $impl ne "" } { + if { [info commands "::callback::${callback}::contract__arg_parser"] eq "" } { # We create a dummy arg parser for the contract in case # the contract hasn't been defined yet. We need this @@ -448,12 +498,55 @@ # 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"] + + if {$::acs::useNsfProc} { + uplevel [::list proc $proc_name_as_passed args \ + " ::callback::${callback}::contract__arg_parser {*}\$args\n${log_code}$code_block"] + } else { + uplevel [::list proc $proc_name_as_passed args \ + " ::callback::${callback}::contract__arg_parser\n${log_code}$code_block"] + } + } elseif { $callback eq "" && [llength $switches] == 0 } { + # + # Nothing special is used in the argument definition, create a + # plain proc + # uplevel [::list proc $proc_name_as_passed $arg_list "${log_code}$code_block"] + } else { - set parser_code " ::upvar args args\n" + # + # Default case, plain Tcl can't handle these cases + # + if {$::acs::useNsfProc} { + # + # nsf::proc can handle these cases. Just in case of the + # callback implementations we have to provide an + # arg_parser of the contract, since OpenACS uses always + # the argument definition of the contract to pass + # arguments in the implementation (which can be very + # confusing). + # + if {$callback ne ""} { + uplevel [::list ::nsf::proc -ad ::callback::${callback}::contract__arg_parser $arg_list { + foreach _ [info vars] { + uplevel [::list set $_ [set $_]] + } + }] + } + #ns_log notice "---- define nsf::proc for [::list proc $proc_name_as_passed $arg_list $code_block]" + uplevel [::list ::nsf::proc -ad $proc_name_as_passed $arg_list ${log_code}$code_block] + return + } + + # + # There is no nsf::proc available. Define for every remaining + # function two procs, one for argument parsing, and one for + # the invocation. The latter one is defined with "args" and + # calls as first step the argument parser. + # + set parser_code " ::upvar args args\n" foreach { name value } [array get default_values] { append parser_code " ::upvar $name val ; ::set val [::list $value]\n" } @@ -508,6 +601,12 @@ ns_write "PARSER CODE:\n\n$parser_code\n\n" } + # + # old style proc + # for a function foo, define "foo $args" and "foo__arg_parser" + # + #ns_log notice "=== old style proc $proc_name_as_passed" + 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"] } @@ -604,7 +703,7 @@ \@author Roberto Mello \@creation-date 2002-01-21 - \@param oacs_user If this user is already an openacs user. oacs_user_p will be defined. + \@param oacs_user If this user is already an OpenACS user. oacs_user_p will be defined. \@param shazam Magical incantation that calls Captain Marvel. Required parameter. \@param user_id The id for the user to process. Optional with default "" (api-browser will show the default automatically) @@ -614,7 +713,7 @@ } if { $oacs_user_p } { - # Do something if this is an openacs user + # Do something if this is an OpenACS user } } @@ -788,7 +887,7 @@ set base ::callback::${callback}::impl foreach procname [lsort [info commands ${base}::$impl]] { - set c [catch {::uplevel 1 $procname $args} ret] + set c [catch {::uplevel 1 [::list $procname {*}$args]} ret] switch -exact $c { 0 { # code ok if { $ret ne "" } { @@ -946,3 +1045,9 @@ return 1 } + +# Local variables: +# mode: tcl +# tcl-indent-level: 4 +# indent-tabs-mode: nil +# End: