OpenACS

yon
committed
MAIN:yon:20020515174713
on 15 May 02
removed extra brace
openacs-4/.../acs-bootstrap-installer/tcl/00-proc-procs.tcl (+32 -32)
112 112         return -code error "Switch -warn can be provided to ad_proc only if -deprecated is also provided"
113 113     }
114 114
115 115     # Now $i is set to the index of the first non-switch argument.
116 116     # There must be either three or four arguments remaining.
117 117     set n_args_remaining [expr { [llength $args] - $i }]
118 118     if { $n_args_remaining != 3 && $n_args_remaining != 4 } {
119 119         return -code error "Wrong number of arguments passed to ad_proc"
120 120     }
121 121
122 122     # Set up the remaining arguments.
123 123     set proc_name [lindex $args $i]
124 124
125 125     # (SDW - OpenACS). If proc_name is being defined inside a namespace, we
126 126     # want to use the fully qualified name. Except for actually defining the
127 127     # proc where we want to use the name as passed to us. We always set
128 128     # proc_name_as_passed and conditionally make proc_name fully qualified
129 129     # if we were called from inside a namespace eval.
130 130
131 131     set proc_name_as_passed $proc_name
132       set proc_namespace [uplevel {namespace current}]
  132     set proc_namespace [uplevel {::namespace current}]
133 133     if { $proc_namespace != "::" } {
134 134         regsub {^::} $proc_namespace {} proc_namespace
135 135         set proc_name "${proc_namespace}::${proc_name}"
136 136     }
137 137
138 138     set arg_list [lindex $args [expr { $i + 1 }]]
139 139     if { $n_args_remaining == 3 } {
140 140         # No doc string provided.
141 141         array set doc_elements [list]
142 142         set doc_elements(main) ""
143 143     } else {
144 144         # Doc string was provided.
145 145         ad_parse_documentation_string [lindex $args end-1] doc_elements
146 146     }
147 147     set code_block [lindex $args end]
148 148
149 149     #####
150 150     #
151 151     #  Parse the argument list.
152 152     #
 
204 204                     return -code error "Invalid flag \"$flag\""
205 205                 }
206 206                 lappend arg_flags $flag
207 207             }
208 208         } elseif { [llength $arg_split] != 1 } {
209 209             return -code error "Invalid element \"$arg\" in argument list"
210 210         }
211 211
212 212         if { [string equal [string index $arg 0] "-"] } {
213 213             if { [llength $positionals] > 0 } {
214 214                 return -code error "Switch -$arg specified after positional parameter"
215 215             }
216 216
217 217             set switch_p 1
218 218             set arg [string range $arg 1 end]
219 219             lappend switches $arg
220 220
221 221             if { [lsearch $arg_flags "boolean"] >= 0 } {
222 222                 set default_values(${arg}_p) 0
223 223                 append switch_code "            -$arg - -$arg=1 {
224                   uplevel set ${arg}_p 1
  224                 ::uplevel ::set ${arg}_p 1
225 225             }
226 226             -$arg=0 {
227                   uplevel set ${arg}_p 0
  227                 ::uplevel ::set ${arg}_p 0
228 228             }
229 229 "
230 230             } else {
231 231                 append switch_code "            -$arg {
232 232                 if { \$i >= \[llength \$args\] - 1 } {
233                       return -code error \"No argument to switch -$arg\"
  233                     ::return -code error \"No argument to switch -$arg\"
234 234                 }
235                   upvar ${arg} val ; set val \[lindex \$args \[incr i\]\]\n"
  235                 ::upvar ${arg} val ; ::set val \[::lindex \$args \[::incr i\]\]\n"
236 236                 append switch_code "            }\n"
237 237             }
238 238
239 239             if { [lsearch $arg_flags "required"] >= 0 } {
240                   append check_code "    if { !\[uplevel info exists $arg\] } {
241           return -code error \"Required switch -$arg not provided\"
  240                 append check_code "    ::if { !\[::uplevel ::info exists $arg\] } {
  241         ::return -code error \"Required switch -$arg not provided\"
242 242     }
243 243 "
244 244             }
245 245         } else {
246 246             set switch_p 0
247 247             if { $default_p } {
248 248                 incr n_positionals_with_defaults
249 249             }
250 250             if { !$default_p && $n_positionals_with_defaults != 0 } {
251 251                 return -code error "Positional parameter $arg needs a default value (since it follows another positional parameter with a default value)"
252 252             }
253 253             lappend positionals $arg
254 254         }
255 255
256 256         set flags($arg) $arg_flags
257 257
258 258         if { $default_p } {
259 259             set default_values($arg) $default_value
260 260         }
261 261
 
281 281     set doc_elements(script) $script
282 282     if { ![nsv_exists api_proc_doc $proc_name] } {
283 283         nsv_lappend api_proc_doc_scripts $script $proc_name
284 284     }
285 285
286 286     nsv_set api_proc_doc $proc_name [array get doc_elements]
287 287
288 288     # Backward compatibility: set proc_doc and proc_source_file
289 289     nsv_set proc_doc $proc_name [lindex $doc_elements(main) 0]
290 290     if { [nsv_exists proc_source_file $proc_name] \
291 291             && [string compare [nsv_get proc_source_file $proc_name] [info script]] != 0 } {
292 292         ns_log Notice "Multiple definition of $proc_name in [nsv_get proc_source_file $proc_name] and [info script]"
293 293     }
294 294     nsv_set proc_source_file $proc_name [info script]
295 295
296 296     if { [string equal $code_block "-"] } {
297 297         return
298 298     }
299 299
300 300     if { [llength $switches] == 0 } {
301           uplevel [list proc $proc_name_as_passed $arg_list $code_block]
  301         uplevel [::list proc $proc_name_as_passed $arg_list $code_block]
302 302     } else {
303           set parser_code "    upvar args args\n"
  303         set parser_code "    ::upvar args args\n"
304 304
305 305         foreach { name value } [array get default_values] {
306               append parser_code "    upvar $name val ; set val [list $value]\n"
  306             append parser_code "    ::upvar $name val ; ::set val [::list $value]\n"
307 307         }
308 308        
309 309         append parser_code "
310       for { set i 0 } { \$i < \[llength \$args\] } { incr i } {
311           set arg \[lindex \$args \$i\]
312           if { !\[ad_proc_valid_switch_p \$arg\] } {
313               break
  310     ::for { ::set i 0 } { \$i < \[::llength \$args\] } { ::incr i } {
  311         ::set arg \[::lindex \$args \$i\]
  312         ::if { !\[::ad_proc_valid_switch_p \$arg\] } {
  313             ::break
314 314         }
315           if { \[string equal \$arg \"--\"\] } {
316               incr i
317               break
  315         ::if { \[::string equal \$arg \"--\"\] } {
  316             ::incr i
  317             ::break
318 318         }
319           switch -- \$arg {
  319         ::switch -- \$arg {
320 320 $switch_code
321               default { return -code error \"Invalid switch: \\\"\$arg\\\"\" }
  321             default { ::return -code error \"Invalid switch: \\\"\$arg\\\"\" }
322 322         }
323 323     }
324 324 "
325 325
326 326         set n_required_positionals [expr { [llength $positionals] - $n_positionals_with_defaults }]
327 327         append parser_code "
328       set n_args_remaining \[expr { \[llength \$args\] - \$i }\]
329       if { \$n_args_remaining < $n_required_positionals } {
330           return -code error \"No value specified for argument \[lindex { [lrange $positionals 0 [expr { $n_required_positionals - 1 }]] } \$n_args_remaining\]\"
  328     ::set n_args_remaining \[::expr { \[::llength \$args\] - \$i }\]
  329     ::if { \$n_args_remaining < $n_required_positionals } {
  330         ::return -code error \"No value specified for argument \[::lindex { [::lrange $positionals 0 [::expr { $n_required_positionals - 1 }]] } \$n_args_remaining\]\"
331 331     }
332 332 "
333 333         for { set i 0 } { $i < $n_required_positionals } { incr i } {
334               append parser_code "    upvar [lindex $positionals $i] val ; set val \[lindex \$args \[expr { \$i + $i }\]\]\n"
  334             append parser_code "    ::upvar [::lindex $positionals $i] val ; ::set val \[::lindex \$args \[::expr { \$i + $i }\]\]\n"
335 335         }
336 336         for {} { $i < [llength $positionals] } { incr i } {
337                   append parser_code "    if { \$n_args_remaining > $i } {
338           upvar [lindex $positionals $i] val ; set val \[lindex \$args \[expr { \$i + $i }\]\]
  337                 append parser_code "    ::if { \$n_args_remaining > $i } {
  338         ::upvar [::lindex $positionals $i] val ; ::set val \[::lindex \$args \[::expr { \$i + $i }\]\]
339 339     }
340 340 "
341 341         }
342 342    
343 343         if { $varargs_p } {
344               append parser_code "    set args \[lrange \$args \[expr { \$i + [llength $positionals] }\] end\]\n"
  344             append parser_code "    ::set args \[::lrange \$args \[::expr { \$i + [::llength $positionals] }\] end\]\n"
345 345         } else {
346               append parser_code "    if { \$n_args_remaining > [llength $positionals] } {
  346             append parser_code "    ::if { \$n_args_remaining > [::llength $positionals] } {
347 347         return -code error \"Too many positional parameters specified\"
348 348     }
349       unset args
  349     ::unset args
350 350 "
351 351         }
352 352
353 353         append parser_code $check_code
354 354
355 355         if { $debug_p } {
356 356             ns_write "PARSER CODE:\n\n$parser_code\n\n"
357 357         }
358 358
359           uplevel [list proc ${proc_name_as_passed}__arg_parser {} $parser_code]
360           uplevel [list proc $proc_name_as_passed args "    ${proc_name_as_passed}__arg_parser\n$code_block"]
  359         uplevel [::list proc ${proc_name_as_passed}__arg_parser {} $parser_code]
  360         uplevel [::list proc $proc_name_as_passed args "    ${proc_name_as_passed}__arg_parser\n$code_block"]
361 361     }
362 362 }
363 363
364 364 ad_proc -public -deprecated proc_doc { args } {
365 365
366 366     A synonym for <code>ad_proc</code> (to support legacy code).
367 367    
368 368 } {
369 369     eval ad_proc $args
370 370 }
371 371
372 372 ad_proc -public ad_proc {
373 373     -public:boolean
374 374     -private:boolean
375 375     -deprecated:boolean
376 376     -warn:boolean
377 377     arg_list
378 378     args
379 379 } {
380 380