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.62 -r1.63 --- openacs-4/packages/acs-bootstrap-installer/tcl/00-proc-procs.tcl 25 Jul 2018 12:55:01 -0000 1.62 +++ openacs-4/packages/acs-bootstrap-installer/tcl/00-proc-procs.tcl 25 Jul 2018 13:03:05 -0000 1.63 @@ -24,7 +24,7 @@ # Note that this will return true for empty string! # - # TODO: Why not use Tcl's "string is double" ? + # TODO: Why not use Tcl's "string is double" ? } proc empty_string_p { query_string } { @@ -42,7 +42,7 @@ proc ad_make_relative_path { path } { set root_length [string length $::acs::rootdir] if { $::acs::rootdir eq [string range $path 0 $root_length-1] } { - return [string range $path $root_length+1 [string length $path]] + return [string range $path $root_length+1 [string length $path]] } error "$path is not under the path root ($::acs::rootdir)" } @@ -53,7 +53,7 @@ # keep the previous state of ::errorInfo # set errorInfo $::errorInfo - + for { set x [expr {[info level] + $level}] } { $x > 0 } { incr x -1 } { set info [info level $x] regsub -all \n $info {\\n} info @@ -100,13 +100,13 @@ set buffer "" foreach line $lines { - - # lars@pinds.com, 8 July, 2000 - # We don't do a string trim anymore, because it breaks the formatting of - # code examples in the documentation, something that we want to encourage. - # set line [string trim $line] + # lars@pinds.com, 8 July, 2000 + # We don't do a string trim anymore, because it breaks the formatting of + # code examples in the documentation, something that we want to encourage. + # set line [string trim $line] + if { [regexp {^[ \t]*@([-a-zA-Z_]+)(.*)$} $line "" element remainder] } { lappend elements($current_element) [string trim $buffer] @@ -157,7 +157,7 @@ -deprecated { set deprecated_p 1 } -warn { set warn_p 1 } -debug { set debug_p 1 } - -callback { + -callback { incr i set callback [lindex $args $i] if { [ad_proc_valid_switch_p $callback] } { @@ -195,7 +195,7 @@ } if { $deprecated_p } { - set warn_p 1 + set warn_p 1 } if { $impl ne "" && $callback eq "" } { @@ -215,10 +215,10 @@ set n_args_remaining [expr { [llength $args] - $i }] if {$callback eq ""} { - # + # # 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" } @@ -227,21 +227,21 @@ set proc_name [lindex $args $i] } else { if {$impl ne "" } { - # + # # 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 a contract for a callback - # + # + # 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 - && [lindex $args end] ne "" + && [lindex $args end] ne "" && [lindex $args end] ne "-" } { return -code error "ad_proc callback contract must have an empty code_body" } @@ -268,9 +268,9 @@ # if we were called from inside a namespace eval. # - # RBM: 2003-01-26: - # With the help of Michael Cleverly, fixed the namespace code so procs - # declared like ::foo::bar would work, by only trimming the first :: + # RBM: 2003-01-26: + # With the help of Michael Cleverly, fixed the namespace code so procs + # declared like ::foo::bar would work, by only trimming the first :: # Also moved the uplevel'd call to namespace current to the if statement, # to avoid it being called unnecessarily. # @@ -305,7 +305,7 @@ # 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) "" + set doc_elements(main) "" } else { # Doc string was provided. ad_parse_documentation_string [lindex $args end-1] doc_elements @@ -339,7 +339,7 @@ # Parse the argument list. # ##### - + set switches [list] set positionals [list] set seen_positional_with_default_p 0 @@ -354,7 +354,7 @@ if { [llength $arg_list] > 0 } { set first_arg [lindex $arg_list 0] if { [llength $first_arg] == 0 || [llength $first_arg] > 2 } { - ns_log Warning "Convert old (deprecated) style proc: $proc_name" + ns_log Warning "Convert old (deprecated) style proc: $proc_name" set new_arg_list [list] foreach { switch default_value } $first_arg { lappend new_arg_list [list $switch $default_value] @@ -409,27 +409,27 @@ if {"boolean" in $arg_flags} { set default_values(${arg}_p) 0 - append switch_code " -$arg - -$arg=1 - -$arg=t - -$arg=true { - ::uplevel ::set ${arg}_p 1 - } - -$arg=0 - -$arg=f - -$arg=false { - ::uplevel ::set ${arg}_p 0 - } -" + append switch_code " -$arg - -$arg=1 - -$arg=t - -$arg=true { + ::uplevel ::set ${arg}_p 1 + } + -$arg=0 - -$arg=f - -$arg=false { + ::uplevel ::set ${arg}_p 0 + } + " } else { - append switch_code " -$arg { - if { \$i >= \[llength \$args\] - 1 } { - ::return -code error \"No argument to switch -$arg\" - } - ::upvar ${arg} val ; ::set val \[::lindex \$args \[::incr i\]\]\n" - append switch_code " }\n" + append switch_code " -$arg { + if { \$i >= \[llength \$args\] - 1 } { + ::return -code error \"No argument to switch -$arg\" + } + ::upvar ${arg} val ; ::set val \[::lindex \$args \[::incr i\]\]\n" + append switch_code " }\n" } if {"required" in $arg_flags} { append check_code " ::if { !\[::uplevel ::info exists $arg\] } { - ::return -code error \"Required switch -$arg not provided\" - } -" + ::return -code error \"Required switch -$arg not provided\" + } + " } } else { set switch_p 0 @@ -459,13 +459,13 @@ foreach element { default_values flags } { set doc_elements($element) [array get $element] } - + set script [info script] set root_length [string length $::acs::rootdir] if { $::acs::rootdir eq [string range $script 0 $root_length-1] } { set script [string range $script $root_length+1 end] } - + set doc_elements(script) $script if { ![nsv_exists api_proc_doc $proc_name] } { nsv_lappend api_proc_doc_scripts $script $proc_name @@ -475,8 +475,8 @@ # Backward compatibility: set proc_doc and proc_source_file nsv_set proc_doc $proc_name [lindex $doc_elements(main) 0] - if { [nsv_exists proc_source_file $proc_name] - && [nsv_get proc_source_file $proc_name] ne [info script] + if { [nsv_exists proc_source_file $proc_name] + && [nsv_get proc_source_file $proc_name] ne [info script] } { ns_log Warning "Multiple definition of $proc_name in [nsv_get proc_source_file $proc_name] and [info script]" } @@ -488,8 +488,8 @@ } 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 - } + # this is a callback contract which only invokes its arg parser for input validation + } } } @@ -513,98 +513,98 @@ if {$::acs::useNsfProc} { uplevel [::list proc $proc_name_as_passed args \ - " ::callback::${callback}::contract__arg_parser {*}\$args\n${log_code}$code_block"] + " ::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"] + " ::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 - # + # + # 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 { - # - # Default case, plain Tcl can't handle these cases - # + # + # 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 { + # + # 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 - } + #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. - # + # + # 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" } - + append parser_code " - ::for { ::set i 0 } { \$i < \[::llength \$args\] } { ::incr i } { - ::set arg \[::lindex \$args \$i\] - ::if { !\[::ad_proc_valid_switch_p \$arg\] } { - ::break - } - ::if { \[::string equal \$arg \"--\"\] } { - ::incr i - ::break - } - ::switch -- \$arg { -$switch_code - default { ::return -code error \"Invalid switch: \\\"\$arg\\\"\" } - } - } -" + ::for { ::set i 0 } { \$i < \[::llength \$args\] } { ::incr i } { + ::set arg \[::lindex \$args \$i\] + ::if { !\[::ad_proc_valid_switch_p \$arg\] } { + ::break + } + ::if { \[::string equal \$arg \"--\"\] } { + ::incr i + ::break + } + ::switch -- \$arg { + $switch_code + default { ::return -code error \"Invalid switch: \\\"\$arg\\\"\" } + } + } + " set n_required_positionals [expr { [llength $positionals] - $n_positionals_with_defaults }] append parser_code " - ::set n_args_remaining \[::expr { \[::llength \$args\] - \$i }\] - ::if { \$n_args_remaining < $n_required_positionals } { - ::return -code error \"No value specified for argument \[::lindex { [::lrange $positionals 0 [::expr { $n_required_positionals - 1 }]] } \$n_args_remaining\]\" - } -" + ::set n_args_remaining \[::expr { \[::llength \$args\] - \$i }\] + ::if { \$n_args_remaining < $n_required_positionals } { + ::return -code error \"No value specified for argument \[::lindex { [::lrange $positionals 0 [::expr { $n_required_positionals - 1 }]] } \$n_args_remaining\]\" + } + " for { set i 0 } { $i < $n_required_positionals } { incr i } { - append parser_code " ::upvar [::lindex $positionals $i] val ; ::set val \[::lindex \$args \[::expr { \$i + $i }\]\]\n" + append parser_code " ::upvar [::lindex $positionals $i] val ; ::set val \[::lindex \$args \[::expr { \$i + $i }\]\]\n" } for {} { $i < [llength $positionals] } { incr i } { - append parser_code " ::if { \$n_args_remaining > $i } { - ::upvar [::lindex $positionals $i] val ; ::set val \[::lindex \$args \[::expr { \$i + $i }\]\] - } -" + append parser_code " ::if { \$n_args_remaining > $i } { + ::upvar [::lindex $positionals $i] val ; ::set val \[::lindex \$args \[::expr { \$i + $i }\]\] + } + " } - + if { $varargs_p } { append parser_code " ::set args \[::lrange \$args \[::expr { \$i + [::llength $positionals] }\] end\]\n" } else { append parser_code " ::if { \$n_args_remaining > [::llength $positionals] } { - return -code error \"Too many positional parameters specified\" - } - ::unset args -" + return -code error \"Too many positional parameters specified\" + } + ::unset args + " } append parser_code $check_code @@ -613,12 +613,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" - + # + # 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"] } @@ -633,46 +633,46 @@ {-impl ""} arg_list [doc_string] - body + body } {

Declare a procedure with the following enhancements over regular Tcl "proc":

- +

When a parameter is declared as boolean, it creates a variable $param_name_p. - For example: -foo:boolean will create a variable $foo_p. - If the parameter is passed, $foo_p will have value 1. Otherwise, + For example: -foo:boolean will create a variable $foo_p. + If the parameter is passed, $foo_p will have value 1. Otherwise, $foo_p will have value 0.

- Boolean named parameters can optionally take a boolean value than can + Boolean named parameters can optionally take a boolean value than can make your code cleaner. The following example by Michael Cleverly shows why: If you had a procedure declared as ad_proc foobar {-foo:boolean} { ... }, it could be invoked as foobar -foo, which could yield some code like - the following in your procedure: + the following in your procedure: 

 if {$flush_p} {
@@ -685,7 +685,7 @@
     

       However, you could invoke the procedure as foobar -foo=$some_boolean_value
       (where some_boolean_value can be 0, 1, t, f, true, false),
-      which could make your procedure cleaner because you could write instead: 
+      which could make your procedure cleaner because you could write instead:
       some_proc -flush=$foo_p $key.
     

     

@@ -763,32 +763,32 @@
         
  • then define an implementation with
             ad_proc -callback foo::bar::zip -impl myimpl  { } { } { #code }
         
  • Two ways to call:
-		
-        
  • in both cases the result is a list of the results of each called implementation (with empty results removed),
-	    so in the case of calling a specific implementation you get a list of one element as the result
-	
  • See callback for more info.
+            
+            
  • in both cases the result is a list of the results of each called implementation (with empty results removed),
+            so in the case of calling a specific implementation you get a list of one element as the result
+        
  • See callback for more info.
       
     
    
 
 
     @param public specifies that the procedure is part of a public API.
     @param private specifies that the procedure is package-private.
     @param deprecated specifies that the procedure should not be used.
-    @param warn specifies that the procedure should generate a warning 
+    @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 
+    @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).
-    @param body the procedure body.  Documentation may be provided for an arbitrary function 
+    @param body the procedure body.  Documentation may be provided for an arbitrary function
     by passing the body as a "-".
 
 } -
@@ -806,37 +806,37 @@
 
 } {
     if {[lindex $allowed_args end] eq "args"} {
-	set varargs_p 1
-	set allowed_args [lrange $allowed_args 0 [llength $allowed_args]-2]
+        set varargs_p 1
+        set allowed_args [lrange $allowed_args 0 [llength $allowed_args]-2]
     } else {
-	set varargs_p 0
+        set varargs_p 0
     }
 
     if { $varargs_p } {
-	upvar args args
-	set args [list]
+        upvar args args
+        set args [list]
     }
 
     set counter 0
     foreach { switch value } $argv {
-	if { [string index $switch 0] ne "-" } {
-	    if { $varargs_p } {
-		set args [lrange $argv $counter end]
-		return
-	    }
-	    return -code error "Expected switch but encountered \"$switch\""
-	}
-	set switch [string range $switch 1 end]
-	if { [lsearch $allowed_args $switch] < 0 } {
-	    return -code error "Invalid switch -$switch (expected one of -[join $allowed_args ", -"])"
-	}
-	upvar $switch switch_var
-	set switch_var $value
-	incr counter 2
+        if { [string index $switch 0] ne "-" } {
+            if { $varargs_p } {
+            set args [lrange $argv $counter end]
+            return
+            }
+            return -code error "Expected switch but encountered \"$switch\""
+        }
+        set switch [string range $switch 1 end]
+        if { [lsearch $allowed_args $switch] < 0 } {
+            return -code error "Invalid switch -$switch (expected one of -[join $allowed_args ", -"])"
+        }
+        upvar $switch switch_var
+        set switch_var $value
+        incr counter 2
     }
     if { [llength $argv] % 2 != 0 } {
-	# The number of arguments has to be even!
-	return -code error "Invalid switch syntax - no argument to final switch \"[lindex $argv end]\""
+        # The number of arguments has to be even!
+        return -code error "Invalid switch syntax - no argument to final switch \"[lindex $argv end]\""
     }
 }
 
@@ -907,7 +907,7 @@
         error "callback: no callback name given"
     }
     # see that the contract exists and call the contract for
-    # arg validation -- ::callback::${callback}::contract is an 
+    # arg validation -- ::callback::${callback}::contract is an
     # empty function that only runs the ad_proc generated arg parser.
 
     if {[info commands ::callback::${callback}::contract] eq ""} {
@@ -937,7 +937,7 @@
                 return [list $ret]
             }
             3 { # code break -- terminate return current list of results.
-                if { $ret ne "" } { 
+                if { $ret ne "" } {
                     lappend returns $ret
                 }
                 return $returns
@@ -983,17 +983,17 @@
     returns 1 if a string is empty; this is better than using == because it won't fail on long strings of numbers
 } -
 
-ad_proc -public acs_root_dir {} { 
-    Returns the path root for the OpenACS installation. 
+ad_proc -public acs_root_dir {} {
+    Returns the path root for the OpenACS installation.
 } -
 
-ad_proc -public acs_package_root_dir { package_key } { 
+ad_proc -public acs_package_root_dir { package_key } {
     Returns the path root for a particular package within the OpenACS installation.
     For example /web/yourserver/packages/foo, i.e., a full file system path with no ending slash.
 } -
 
-ad_proc -public ad_make_relative_path { path } { 
-    Returns the relative path corresponding to absolute path $path. 
+ad_proc -public ad_make_relative_path { path } {
+    Returns the relative path corresponding to absolute path $path.
 } -
 
 # procedures for doing type based dispatch
@@ -1021,7 +1021,7 @@
 ad_proc -public ad_call_method {
     method_name
     object_id
-    args 
+    args
 } {
     Calls method_name for the type of object_id with object_id as the
     first arg, and the remaining args are the remainder of the args to
@@ -1038,7 +1038,7 @@
 ad_proc -public ad_dispatch {
     method_name
     type
-    args 
+    args
 } {
     Calls method_name with the type as the first arg, and the remaining args are
     the remainder of the args to method_name.
@@ -1079,7 +1079,7 @@
 
 ad_proc -public ad_with_deprecated_code_p {} {
     Check, if we should load deprecated code.
-    
+
     In order to skip loading of deprecated code, use the following
     snippet in your config file