1########################################################################## 2# TEPAM - Tcl's Enhanced Procedure and Argument Manager 3########################################################################## 4# 5# tepam.tcl - TEPAM's main Tcl package 6# 7# TEPAM offers an alternative way to declare Tcl procedures. It provides 8# enhanced argument handling features like automatically generated, 9# graphical entry forms and checkers for the procedure arguments. 10# 11# Copyright (C) 2009/2010 Andreas Drollinger 12# 13# RCS: @(#) $Id: tepam.tcl,v 1.1 2010/02/11 21:50:55 droll Exp $ 14########################################################################## 15# See the file "license.terms" for information on usage and redistribution 16# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 17########################################################################## 18 19package require Tcl 8.3 20 21namespace eval tepam { 22 23 # This is the following TEPAM version: 24 variable version 0.1.0 25 26 # Exports the major commands from this package: 27 namespace export procedure argument_dialogbox 28 29########################################################################## 30# procedure # 31########################################################################## 32 33 ######## Procedure configuration ######## 34 35 # Set the following variable to 0 (false) prior to the procedure definition, to 36 # use first the unnamed arguments and then the named arguments. 37 set named_arguments_first 1 38 39 # Setting the following variable to 0 will disable the automatic argument name 40 # extension feature. 41 set auto_argument_name_completion 1 42 43 # Set the following variable to "short" to generate small interactive dialog boxes. 44 set interactive_display_format "extended" 45 46 # The following variable defines the maximum line length a created help text can have: 47 set help_line_length 80 48 49 ######## Internal variables ######## 50 51 if {![info exists ProcedureList]} { 52 set ProcedureList {} 53 } 54 55 ######## PureProcName ######## 56 57 # PureProcName purifies the procedure name given by the ProcName variable of the calling 58 # function and returns it. 59 proc PureProcName {args} { 60 upvar ProcName ProcName 61 set Name $ProcName 62 regsub {^::} $Name {} Name; # Eliminate the main namespace indicators 63 if {[lsearch $args -appo]>=0} { # Encapsulate the name into '' if it is a composed name 64 set Name "'$Name'" 65 } 66 return $Name 67 } 68 69 ######## Procedure help text ######## 70 71 set ProcedureHelp { 72 procedure <ProcedureName> <ProcedureAttributes> <ProcedureBody> 73 74 <ProcedureAttributes> = { 75 [-category <Category>] 76 [-short_description <ShortDescription>] 77 [-description <Description>] 78 [-return <Return_Type>] 79 [-example <Example>] 80 [-named_arguments_first 0|1] 81 [-auto_argument_name_completion 0|1] 82 [-interactive_display_format] 83 [-args <ArgumentDeclarationList>] 84 } 85 86 <ArgumentDeclarationList> = {<ArgumentDeclaration> [ArgumentDeclaration ...]} 87 88 <ArgumentDeclaration> = { 89 <Argument_Name> 90 [-description <ArgumentDescription>] 91 [-type <ArgumentType>] 92 [-validatecommand <ValidateCommand>] 93 [-default <DefaultValue>] 94 [-optional | -mandatory] 95 [-choices <ChoiceList>] 96 [-choicelabels <ChoiceLabelList>] 97 [-range {<MinValue> <MaxValue>} 98 [-multiple] 99 [-auxargs <AuxilaryArgumentList>] 100 [-auxargs_commands <AuxilaryArgumentCommandList>] 101 } 102 103 <ArgumentType> = { 104 none double integer alnum alpha ascii control digit graph lower 105 print punct space upper wordchar xdigit color font boolean "" 106 } 107 } 108 109 # Eliminate leading tabs in the help text and replace eventual tabs through spaces 110 regsub -all -line {^\t\t} $ProcedureHelp "" ProcedureHelp 111 regsub -all -line {\t} $ProcedureHelp " " ProcedureHelp 112 113 ######## Procedure ######## 114 115 # Procedure allows declaring a new procedure in the TEPAM syntax: 116 # 117 # procedure my_proc { 118 # -args {message} 119 # } { 120 # puts $message; # Procedure body 121 # } 122 # 123 # Procedure creates in fact a TCL procedure with a patched procedure body. This body calls at 124 # the beginning an argument parser (ProcedureArgumentEvaluation)that is reading and validating 125 # the arguments that have been provided to the procedure. The previous lines are for example 126 # creating the following TCL procedure: 127 # 128 # proc my_proc {args} { 129 # ::tepam::ProcedureArgumentEvaluation; 130 # if {$ProcedureArgumentEvaluationResult!=""} { 131 # if {$ProcedureArgumentEvaluationResult=="cancel"} return; 132 # return -code error $ProcedureArgumentEvaluationResult; 133 # } 134 # if {$SubProcedure!=""} {return [$SubProcedure]}; 135 # 136 # puts $message; # Procedure body 137 # } 138 # 139 # ProcedureArgumentEvaluation uses the TCL procedure's args argument to read all the provided 140 # arguments. It evaluates first if a sub procedure has to be called. This information and the 141 # argument validation result are provided to the calling procedure respectively via the 142 # variables SubProcedure and ProcedureArgumentEvaluationResult. In case the result evaluation 143 # was not successful, the calling procedure body will simply return. In case the procedure 144 # call refers to a sub-procedure, this one will be called. Otherwise, if a valid argument set 145 # has been provided to the procedure, and if no sub-procedure has to be called, the original 146 # procedure body is executed. 147 # Procedure behaves slightly differently in case one or multiple sub-procedures have been 148 # declared without declaring the main procedure itself: 149 # 150 # procedure {my_func sub_func} { 151 # -args {message} 152 # } { 153 # puts $message; # Procedure body 154 # } 155 # 156 # Procedure creates in this case for the main procedure a Tcl procedure as well as for the sub 157 # procedure. The main procedure creates an error when it directly called. The sub-procedure 158 # is executed within the main procedure's context using the uplevel command. 159 # 160 # proc my_proc {args} { 161 # ::tepam::ProcedureArgumentEvaluation; 162 # if {$ProcedureArgumentEvaluationResult!=""} { 163 # if {$ProcedureArgumentEvaluationResult=="cancel"} return; 164 # return -code error $ProcedureArgumentEvaluationResult; 165 # } 166 # if {$SubProcedure!=""} {return [$SubProcedure]}; 167 # error "'my_func' requires a subcommand" 168 # } 169 # 170 # proc {my_proc sub_func} {args} { 171 # uplevel 1 { 172 # puts $message; # Procedure body 173 # } 174 # } 175 # 176 # Procedure parses itself the procedure name and attributes and creates the new TCL procedure 177 # with the modified body. For each declared argument it calls ProcedureArgDef which handles the 178 # argument definition. 179 180 proc procedure {args} { 181 variable ProcDef 182 variable ProcedureHelp 183 variable named_arguments_first 184 variable auto_argument_name_completion 185 variable interactive_display_format 186 variable ProcedureList 187 188 #### Check if help is requested and extract the (sub) procedure name #### 189 190 # Check if help is requested: 191 if {[lsearch -exact $args "-help"]>=0} { 192 puts $ProcedureHelp 193 return 194 } 195 196 # Check that the procedure name, argument list and body has been provided: 197 if {[llength $args]!=3} { 198 return -code error "Missing procedure arguments, correct usage: procedure <ProcedureName>\ 199 <ProcedureAttributes> <ProcedureBody>" 200 } 201 202 # Evaluate the complete procedure name including a leading name space identifier. 203 # Evaluate the current namespace in case the procedure is not defined explicitly with 204 # a name space: 205 regsub -all {\s+} [lindex $args 0] " " ProcName 206 if {[string range $ProcName 0 1]!="::"} { 207 set NameSpace [uplevel 1 {namespace current}] 208 if {$NameSpace!="::"} {append NameSpace "::"} 209 set ProcName ${NameSpace}${ProcName} 210 } 211 212 # Extract the procedure attributes and the procedure body: 213 set ProcedureAttributes [lindex $args 1] 214 set ProcedureBody [lindex $args 2] 215 216 # Store the procedure name in the procedure list, if it is not already existing: 217 if {[lsearch -exact $ProcedureList $ProcName]} { 218 lappend ProcedureList $ProcName 219 } 220 221 #### Initialize the procedure attributes #### 222 223 # Clean the information of an eventual previous procedure definition, and store 224 # the actual configured procedure modes: 225 catch {array unset ProcDef $ProcName,*} 226 set ProcDef($ProcName,-named_arguments_first) $named_arguments_first 227 set ProcDef($ProcName,-auto_argument_name_completion) $auto_argument_name_completion 228 set ProcDef($ProcName,-interactive_display_format) $interactive_display_format 229 230 # The procedure information will be stored in the array variable ProcDef. 231 # The following array members are always defined for each declared procedure: 232 set ProcDef($ProcName,VarList) {} 233 set ProcDef($ProcName,NamedVarList) {} 234 set ProcDef($ProcName,UnnamedVarList) {} 235 # ProcDef($ProcName,NbrVars); # 236 # ProcDef($ProcName,NbrNamedVars) 237 # ProcDef($ProcName,NbrUnnamedVars) 238 239 # The following array members be defined optionally in the argument parsing section: 240 # ProcDef($ProcName,$AttributeName) 241 # | AttributeName = {-category -return -short_description 242 # | -description -example} 243 # 244 # ProcDef($ProcName,Arg,$Var,IsNamed) 245 # ProcDef($ProcName,Arg,$Var,-type) 246 # ProcDef($ProcName,Arg,$Var,-optional) 247 # ProcDef($ProcName,Arg,$Var,-validatecommand) 248 # ProcDef($ProcName,Arg,$Var,-default) 249 # ProcDef($ProcName,Arg,$Var,HasDefault) 250 # ProcDef($ProcName,Arg,$Var,-multiple) 251 # ProcDef($ProcName,Arg,$Var,-description) 252 # ProcDef($ProcName,Arg,$Var,-choices) 253 # | Contains the choice list: {<Choice1> ... <ChoiceN>} 254 # ProcDef($ProcName,Arg,$Var,-choicelabels) 255 # | Contains the choice label list: {<ChoiceLabel1> ... <ChoiceLabelN>} 256 # ProcDef($ProcName,Arg,$Var,-range) 257 # ProcDef($ProcName,Arg,$Var,SectionComment) 258 # ProcDef($ProcName,Arg,$Var,Comment) 259 260 #### Parse all procedure attributes #### 261 262 set UnnamedHasToBeOptional 0; # Variable that will be set to '1' if an unnamed argument is optional. 263 set UnnamedWasMultiple 0; # Variable that will be set to '1' if an unnamed argument has the -multiple option 264 265 # Loop through the argument definition list: 266 foreach {AttributeName AttributeValue} $ProcedureAttributes { 267 # Evaluate the provided argument attribute 268 switch -exact -- $AttributeName { 269 -help { # Help has been required in the procedure attribute definition list: 270 puts $ProcedureHelp 271 return 272 } 273 -category - 274 -return - 275 -short_description - 276 -description - 277 -named_arguments_first - 278 -auto_argument_name_completion - 279 -example - 280 -interactive_display_format { 281 # Save all these information simply in the ProcDef array variable: 282 set ProcDef($ProcName,$AttributeName) $AttributeValue 283 } 284 -args { 285 # Read the procedure arguments with ProcedureArgDef 286 set Comment "" 287 set SectionComment "" 288 foreach arg $AttributeValue { 289 set ErrorMsg [ProcedureArgDef $arg] 290 if {$ErrorMsg!=""} { 291 return -code error "Procedure declaration [PureProcName -appo]: $ErrorMsg" 292 } 293 } 294 } 295 default { 296 return -code error "Procedure declaration [PureProcName -appo]: Procedure attribute '$AttributeName' not known" 297 } 298 } 299 } 300 301 # Complete the procedure attributes - 302 # Number of arguments: 303 set ProcDef($ProcName,NbrVars) [llength $ProcDef($ProcName,VarList)] 304 # Number of named arguments 305 set ProcDef($ProcName,NbrNamedVars) [llength $ProcDef($ProcName,NamedVarList)] 306 # Number of unnamed arguments 307 set ProcDef($ProcName,NbrUnnamedVars) [llength $ProcDef($ProcName,UnnamedVarList)] 308 309 #### Create the TCL procedure(s) #### 310 311 # Create now the TCL procedures. In case a sub procedure is declared, the created TCL 312 # procedure has not to call the argument evaluator, since this one has already been called 313 # in the main procedure. An additional main procedure is created if a sub procedure is 314 # declared and if no main procedure is existing. 315 316 set Body "::tepam::ProcedureArgumentEvaluation;\n" 317 append Body "if {\$ProcedureArgumentEvaluationResult!=\"\"} \{\n" 318 append Body " if {\$ProcedureArgumentEvaluationResult==\"cancel\"} return;\n" 319 append Body " return -code error \$ProcedureArgumentEvaluationResult;\n" 320 append Body "\}\n" 321 append Body "if {\$SubProcedure!=\"\"} {return \[\$SubProcedure\]};\n\n" 322 323 if {[llength $ProcName]==1} { 324 append Body "$ProcedureBody" 325 proc $ProcName {args} $Body 326 } else { 327 proc $ProcName {args} "uplevel 1 \{\n$ProcedureBody\n\}" 328 if {[info commands [lindex $ProcName 0]]==""} { 329 append Body "return -code error \"'[lindex $ProcName 0]' requires a subcommand\"" 330 proc [lindex $ProcName 0] {args} $Body 331 } 332 } 333 } 334 335 # ProcedureArgDef reads the definition of a single argument that is provided in form of a list: 336 # 337 # -mtype -default Warning -choices {Info Warning Error} -description "M. type" 338 # 339 # ProcedureArgDef is executed by 'procedure'. The argument definition is provided via the 340 # argument 'ArgDef' variable. ProcedureArgDef is recognizing argument comments and section 341 # comments that can be placed into the argument definitions. ProcedureArgDef is also checking 342 # the validity of the argument specifications. 343 344 proc ProcedureArgDef {ArgDef} { 345 variable ProcDef 346 variable ProcedureHelp 347 variable named_arguments_first 348 variable auto_argument_name_completion 349 variable interactive_display_format 350 variable ProcedureList 351 352 upvar ProcName ProcName 353 upvar Comment Comment 354 upvar SectionComment SectionComment 355 upvar UnnamedHasToBeOptional UnnamedHasToBeOptional 356 upvar UnnamedWasMultiple UnnamedWasMultiple 357 358 # Read the argument name: 359 set Opt [lindex $ArgDef 0] 360 361 #### Handle section and argument comments, parse the option name #### 362 363 # Check if the argument definition is a simply argument comment (either -, "" or {}) 364 if {$Opt=="" || $Opt=="-"} { 365 # Eliminate the entire first word as well as any leading and tailing white spaces 366 regexp {^\s*[^\s]+\s+(.*)\s*$} $ArgDef {} Comment 367 regsub -all "\"" $Comment "\\\"" Comment 368 return "" 369 370 # Check if the argument definition is an argument section begin 371 } elseif {[string index $Opt 0]=="\#"} { 372 # Eliminate leading and tailing white spaces 373 set SectionComment [string trim [string range $ArgDef 1 end]] 374 375 # Eliminate the leading and ending #s and white spaces 376 regexp {^\s*\#+\s*(.*?)\s*\#*\s*$} $ArgDef {} SectionComment 377 # regsub -all "\"" $SectionComment "\\\" SectionComment 378 379 # For an eventual interactive call that requires a GUI, swap to the short 380 # representation mode, since the frames are used to display the sections: 381 set ProcDef($ProcName,-interactive_display_format) "short" 382 return "" 383 384 # Check if the argument is an option or a flag (named argument), that has with a 385 # leading '-': 386 } elseif {[string index $Opt 0]=="-"} { 387 set Var [string range $Opt 1 end] 388 lappend ProcDef($ProcName,NamedVarList) $Var 389 set ProcDef($ProcName,Arg,$Var,IsNamed) 1 390 391 # The argument is an unnamed argument: 392 } else { 393 set Var $Opt 394 lappend ProcDef($ProcName,UnnamedVarList) $Var 395 set ProcDef($ProcName,Arg,$Var,IsNamed) 0 396 } 397 398 # Assign to the argument an eventually previously defined section or argument comment: 399 if {$SectionComment!=""} { 400 set ProcDef($ProcName,Arg,$Var,SectionComment) $SectionComment 401 set SectionComment "" 402 } 403 if {$Comment!=""} { 404 set ProcDef($ProcName,Arg,$Var,Comment) $Comment 405 set Comment "" 406 } 407 408 # Check that an argument is not declared multiple times: 409 if {[lsearch -exact $ProcDef($ProcName,VarList) $Var]>=0} { 410 return "Argument '$Var' defined multiple times" 411 } 412 413 #### Define the argument attributes #### 414 415 # Append the argument to the argument list and define the argument attributes with the 416 # default values: 417 lappend ProcDef($ProcName,VarList) $Var 418 set ProcDef($ProcName,Arg,$Var,-type) ""; # Undefined 419 set ProcDef($ProcName,Arg,$Var,-optional) 0 420 set ProcDef($ProcName,Arg,$Var,HasDefault) 0 421 set ProcDef($ProcName,Arg,$Var,-multiple) 0 422 423 # Parse all argument attribute definitions: 424 for {set a 1} {$a<[llength $ArgDef]} {incr a} { 425 set ArgOption [lindex $ArgDef $a] 426 set ArgOptionValue [lindex $ArgDef [expr {$a+1}]] 427 switch -- $ArgOption { 428 -type { 429 # Argument type definition: Check if the validation command is defined for 430 # the used argument type: 431 if {[catch {Validate($ArgOptionValue) ""}]} { 432 return "Argument type '$ArgOptionValue' not known" 433 } 434 435 # Store the attribute type: 436 set ProcDef($ProcName,Arg,$Var,-type) $ArgOptionValue 437 438 # Flags (argument that have the type 'none') are always optional: 439 if {$ProcDef($ProcName,Arg,$Var,-type)=="none"} { 440 set ProcDef($ProcName,Arg,$Var,-optional) 1 441 } 442 incr a 443 } 444 445 -default { 446 # Arguments that have default values are always optional: 447 set ProcDef($ProcName,Arg,$Var,-default) $ArgOptionValue 448 set ProcDef($ProcName,Arg,$Var,HasDefault) 1 449 set ProcDef($ProcName,Arg,$Var,-optional) 1 450 incr a 451 } 452 453 -mandatory {# The -mandatory attribute is already the default behavior} 454 455 -optional - 456 -multiple { 457 # These attributes (flags) have just to be stored for future usage: 458 set ProcDef($ProcName,Arg,$Var,$ArgOption) 1 459 } 460 461 -validatecommand - 462 -auxargs_commands { 463 # Check the the commands are not empty. Don't define them otherwise: 464 if {$ArgOptionValue!=""} { 465 set ProcDef($ProcName,Arg,$Var,$ArgOption) $ArgOptionValue 466 } 467 incr a 468 } 469 470 -range { 471 # Check that the range is defined by two values and that the min value is 472 # smaller than the max value: 473 if {[llength $ArgOptionValue]!=2 || \ 474 ![Validate(double) [lindex $ArgOptionValue 0]] || \ 475 ![Validate(double) [lindex $ArgOptionValue 1]]} { 476 return "Invalid range definition - $ArgOptionValue" 477 } 478 set ProcDef($ProcName,Arg,$Var,$ArgOption) $ArgOptionValue 479 incr a 480 } 481 482 -auxargs - 483 -description - 484 -choices - 485 -choicelabels { 486 # Also these attributes have just to be stored for future usage: 487 set ProcDef($ProcName,Arg,$Var,$ArgOption) $ArgOptionValue 488 incr a 489 } 490 491 default { 492 # Generate an error if the provided attribute name doesn't match with a known 493 # attribute. 494 return "Argument attribute '$ArgOption' not known" 495 } 496 } 497 } 498 499 #### Perform various argument attribute validation checks #### 500 501 # Unnamed argument attribute checks: 502 if {!$ProcDef($ProcName,Arg,$Var,IsNamed)} { 503 # Check that behind an optional unnamed argumeent there are only other optional 504 # unnamed arguments: 505 if {$UnnamedHasToBeOptional && !$ProcDef($ProcName,Arg,$Var,-optional)} { 506 return "Argument '$Var' has to be optional" 507 } 508 509 # Check that only the last unnamed argument can take multiple values: 510 if {$UnnamedWasMultiple} { 511 return "Attribute '-multiple' is only for the last unnamed argument allowed" 512 } 513 514 # Check the length of an optional -choicelabels list 515 if {[info exists ProcDef($ProcName,Arg,$Var,-choices)] && \ 516 [info exists ProcDef($ProcName,Arg,$Var,-choicelabels)]} { 517 if {[llength $ProcDef($ProcName,Arg,$Var,-choices)]!= 518 [llength $ProcDef($ProcName,Arg,$Var,-choicelabels)]} { 519 return "Argument '$Var' - Choice label list and choice list have different sizes" 520 } 521 } 522 523 # Store the information about the argument attributes the check the consistency of 524 # the following arguments: 525 if {$ProcDef($ProcName,Arg,$Var,-optional)} { 526 set UnnamedHasToBeOptional 1 527 } 528 if {$ProcDef($ProcName,Arg,$Var,-multiple)} { 529 set UnnamedWasMultiple 1 530 } 531 } 532 533 # Range checks are only allowed for integers and doubles: 534 if {[info exists ProcDef($ProcName,Arg,$Var,-range)]} { 535 if {[lsearch {integer double} $ProcDef($ProcName,Arg,$Var,-type)]<0} { 536 return "Argument '$Var' - range specification requires type integer or double" 537 } 538 } 539 540 return "" 541 } 542 543 ######## ProcedureArgumentEvaluation ######## 544 545 # ProcedureArgumentEvaluation is the argument evaluator that is embedded by the procedure 546 # declaration command 'procedure' into the procedure's body in the following way: 547 # 548 # proc my_proc {args} { 549 # ::tepam::ProcedureArgumentEvaluation; 550 # if {$ProcedureArgumentEvaluationResult!=""} { 551 # if {$ProcedureArgumentEvaluationResult=="cancel"} return; 552 # return -code error $ProcedureArgumentEvaluationResult; 553 # } 554 # if {$SubProcedure!=""} {return [$SubProcedure]}; 555 # 556 # puts $message; # Procedure body 557 # } 558 # 559 # ProcedureArgumentEvaluation has to define in the calling procedure two variables: 560 # The first one is ProcedureArgumentEvaluationResult that has to contain the result of the 561 # evaluation and validation of the argument set. Zero as results means that the provided 562 # arguments are OK and that the procedure body can be executed. A non-zero value indicates 563 # that the procedure body has not to be evaluated, typically because help was requested via 564 # the -help option. In case of incorrect arguments an error is generated by 565 # ProcedureArgumentEvaluation. 566 # The second variable that is created by ProcedureArgumentEvaluation is 'SubProcedure'. This 567 # variable is set to the sub procedure name in case a sub procedure is called. If the main 568 # procedure is called this variable is set to an empty string. 569 570 # Delcare first a tiny helper function: ProcedureArgumentEvaluationReturn will assign the 571 # provided result string to the ProcedureArgumentEvaluationResult variable in the context 572 # of the calling procedure and will then emulate a return function. 573 574 proc ProcedureArgumentEvaluationReturn {Result} { 575 upvar 2 ProcedureArgumentEvaluationResult ProcedureArgumentEvaluationResult 576 set ProcedureArgumentEvaluationResult $Result 577 return -code return 578 } 579 580 proc ProcedureArgumentEvaluation {} { 581 variable ProcDef 582 upvar args args 583 upvar SubProcedure SubProcedure 584 585 #### Extract the procedure and sub procedure names, call the procedure help if requested #### 586 587 # Evaluate the complete main procedure name that contains the namespace identification: 588 # The procedure name is given by the first element of 'info level': 589 set ProcedureCallLine [info level -1] 590 set ProcName [lindex $ProcedureCallLine 0] 591 592 # Check if the procedure name contains already the name space identification: 593 if {[string range $ProcName 0 1]!="::"} { 594 # The namespace is not part of the used procedure name call. Evaluate it explicitly: 595 set NameSpace [uplevel 1 {namespace current}] 596 if {$NameSpace!="::"} {append NameSpace "::"} 597 set ProcName ${NameSpace}${ProcName} 598 } 599 600 # Evaluate the sub command names by checking if the first arguments are matching with 601 # a specified sub command name: 602 set SubProcedure "" 603 while {1} { 604 set ProcNameTmp "$ProcName [lindex $args 0]" 605 if {![info exists ProcDef($ProcNameTmp,VarList)] && [array names ProcDef "$ProcNameTmp *"]==""} { 606 # The argument is not matching with a specified sub command name (so it will be a 607 # real argument): 608 break 609 } 610 # Use the argument as sub procedure name: 611 set ProcName $ProcNameTmp 612 set SubProcedure $ProcName 613 set args [lrange $args 1 end] 614 } 615 616 # Check if help has been requested in the procedure call: 617 if {[lindex $args end]=="-help"} { 618 ProcedureHelp $ProcName 619 ProcedureArgumentEvaluationReturn "cancel" 620 } 621 622 # Check if the procedure call is an interactive call 623 set InteractiveCall [string match "-interactive" [lindex $args end]] 624 625 # Return an empty string if the main procedure has been called and if only sub-commands 626 # have been defined, but not the main procedure itself. 627 if {![info exists ProcDef($ProcName,VarList)]} { 628 ProcedureArgumentEvaluationReturn "" 629 } 630 631 #### Call an argument_dialogbox if the procedure has been called with'-interactive' #### 632 633 set NewArgs {} 634 if {$InteractiveCall} { 635 # Start creating the argument_dialogbox's argument list with the title attribute: 636 set DialogBoxArguments [list -title $ProcName -context $ProcName] 637 638 # Create for each of the procedure arguments an entry for the argument_dialogbox: 639 foreach Var $ProcDef($ProcName,VarList) { 640 # Declare the result variables. These variables refer to the variables in the parent 641 # procedure (upvar). Attribute to these variables directly the default values that can be 642 # overwritten later with the new defined values. 643 upvar $Var Variable__$Var 644 645 # Create sections, write section and argument comments: 646 if {$ProcDef($ProcName,-interactive_display_format)=="extended"} { 647 if {[info exists ProcDef($ProcName,Arg,$Var,SectionComment)]} { 648 # If a section comment is defined, close an eventual open frame, add the 649 # section comment and add an eventually defined arguement comment: 650 lappend DialogBoxArguments -frame ""; # Close an eventual open frame 651 lappend DialogBoxArguments \ 652 -comment [list -text $ProcDef($ProcName,Arg,$Var,SectionComment)] 653 if {[info exists ProcDef($ProcName,Arg,$Var,Comment)]} { 654 lappend DialogBoxArguments \ 655 -comment [list -text $ProcDef($ProcName,Arg,$Var,Comment)] 656 } 657 } 658 # Create a frame around each argument entry in the extended format: 659 lappend DialogBoxArguments -frame [list -label $Var] 660 } elseif {[info exists ProcDef($ProcName,Arg,$Var,SectionComment)]} { 661 # If a section is defined, create a section frame in the sort format: 662 lappend DialogBoxArguments \ 663 -frame [list -label $ProcDef($ProcName,Arg,$Var,SectionComment)] 664 } 665 # If an argument comment is defined but not yet applied, apply it: 666 if {[info exists ProcDef($ProcName,Arg,$Var,Comment)] && 667 !( $ProcDef($ProcName,-interactive_display_format)=="extended" && 668 [info exists ProcDef($ProcName,Arg,$Var,SectionComment)] )} { 669 lappend DialogBoxArguments \ 670 -comment [list -text $ProcDef($ProcName,Arg,$Var,Comment)] 671 } 672 673 # Provide to the argument dialogbox all the argument attributes: 674 set ArgAttributes {} 675 if {$ProcDef($ProcName,Arg,$Var,-type)!=""} { 676 lappend ArgAttributes -type $ProcDef($ProcName,Arg,$Var,-type) 677 } 678 if {$ProcDef($ProcName,Arg,$Var,-optional)} { 679 lappend ArgAttributes -optional 1 680 } 681 if {[info exists ProcDef($ProcName,Arg,$Var,-range)] && \ 682 $ProcDef($ProcName,Arg,$Var,-range)!=""} { 683 lappend ArgAttributes -range $ProcDef($ProcName,Arg,$Var,-range) 684 } 685 if {[info exists ProcDef($ProcName,Arg,$Var,-validatecommand)]} { 686 lappend ArgAttributes -validatecommand $ProcDef($ProcName,Arg,$Var,-validatecommand) 687 } 688 if {[info exists ProcDef($ProcName,Arg,$Var,-auxargs)] && $ProcDef($ProcName,Arg,$Var,-auxargs)!=""} { 689 set ArgAttributes [concat $ArgAttributes $ProcDef($ProcName,Arg,$Var,-auxargs)] 690 } 691 if {[info exists ProcDef($ProcName,Arg,$Var,-auxargs_commands)]} { 692 foreach {AuxArg_Name AuxArgCommand} $ProcDef($ProcName,Arg,$Var,-auxargs_commands) { 693 lappend ArgAttributes $AuxArg_Name [uplevel #1 $AuxArgCommand] 694 } 695 } 696 if {[info exists ProcDef($ProcName,Arg,$Var,-choicelabels)]} { 697 lappend ArgAttributes -choicelabels $ProcDef($ProcName,Arg,$Var,-choicelabels) 698 } 699 700 # Set the default values 701 if {[info exists ProcDef($ProcName,Arg,$Var,-default)]} { 702 lappend ArgAttributes -default $ProcDef($ProcName,Arg,$Var,-default) 703 } 704 705 # Add the variable name, type, description and range as labels and comments: 706 set Label $Var; # Default label 707 if {$ProcDef($ProcName,-interactive_display_format)=="extended"} { 708 # Add the argument description as comment 709 if {[info exists ProcDef($ProcName,Arg,$Var,-description)]} { 710 lappend DialogBoxArguments \ 711 -comment [list -text $ProcDef($ProcName,Arg,$Var,-description)] 712 } 713 714 # Add the type and ranges as comment 715 if {[lsearch {"" "string" "none"} $ProcDef($ProcName,Arg,$Var,-type)]<0} { 716 set Comment "Type: $ProcDef($ProcName,Arg,$Var,-type), " 717 if {[info exists ProcDef($ProcName,Arg,$Var,-range)]} { 718 append Comment "range: [lindex $ProcDef($ProcName,Arg,$Var,-range) 0] .. \ 719 [lindex $ProcDef($ProcName,Arg,$Var,-range) 1], " 720 } 721 lappend DialogBoxArguments -comment [list -text [string range $Comment 0 end-2]] 722 } 723 } else { 724 if {[info exists ProcDef($ProcName,Arg,$Var,-description)]} { 725 set Label $ProcDef($ProcName,Arg,$Var,-description) 726 } 727 } 728 729 # Select the adequate widget for the argument: 730 lappend ArgAttributes -label "$Label:" -variable Variable__$Var 731 732 # A type specific widget exists, so use this one: 733 if {[info procs ad_form($ProcDef($ProcName,Arg,$Var,-type))]!=""} { 734 lappend DialogBoxArguments -$ProcDef($ProcName,Arg,$Var,-type) $ArgAttributes 735 736 # Use a simple checkbutton for flags: 737 } elseif {$ProcDef($ProcName,Arg,$Var,-type)=="none"} { 738 lappend DialogBoxArguments -checkbutton $ArgAttributes 739 740 # A choice list is provided with less or equal than 4 options, use radioboxes or checkboxes: 741 } elseif {[info exists ProcDef($ProcName,Arg,$Var,-choices)] && \ 742 [llength $ProcDef($ProcName,Arg,$Var,-choices)]<=4} { 743 if {$ProcDef($ProcName,Arg,$Var,-multiple)} { 744 lappend DialogBoxArguments -checkbox [concat [list \ 745 -choices $ProcDef($ProcName,Arg,$Var,-choices)] $ArgAttributes] 746 } else { 747 lappend DialogBoxArguments -radiobox [concat [list \ 748 -choices $ProcDef($ProcName,Arg,$Var,-choices)] $ArgAttributes] 749 } 750 751 # A choice list is provided with less than 30 options, use a listbox or a disjointlistbox: 752 } elseif {[info exists ProcDef($ProcName,Arg,$Var,-choices)] && \ 753 [llength $ProcDef($ProcName,Arg,$Var,-choices)]<30} { 754 if {$ProcDef($ProcName,Arg,$Var,-multiple)} { 755 lappend DialogBoxArguments -disjointlistbox [concat [list \ 756 -choicevariable ProcDef($ProcName,Arg,$Var,-choices) -height 3] $ArgAttributes] 757 } else { 758 lappend DialogBoxArguments -listbox [concat [list \ 759 -choicevariable ProcDef($ProcName,Arg,$Var,-choices) -height 3] $ArgAttributes] 760 } 761 762 # For all other cases, use a simple entry widget: 763 } else { 764 lappend DialogBoxArguments -entry $ArgAttributes 765 } 766 } 767 768 # Call the argument dialogbox 769 # puts "argument_dialogbox \{$DialogBoxArguments\}" 770 if {[argument_dialogbox $DialogBoxArguments]=="cancel"} { 771 # The argument dialogbox has been canceled, leave the calling procedure without 772 # executing the procedure body: 773 ProcedureArgumentEvaluationReturn cancel 774 } 775 776 # Set the variables of the optional arguments to the default values, if the variables 777 # haven't been defined by the argument dialogbox: 778 foreach Var $ProcDef($ProcName,VarList) { 779 if {![info exists Variable__$Var] && \ 780 [info exists ProcDef($ProcName,Arg,$Var,-default)]} { 781 set Variable__$Var $ProcDef($ProcName,Arg,$Var,-default) 782 } 783 } 784 785 #### Non interactive call: Parse all arguments and define the argument variables #### 786 787 } else { 788 789 # Result variable declaration and default value definition 790 foreach Var $ProcDef($ProcName,VarList) { 791 # Declare the result variables. These variables refer to the variables in the parent 792 # procedure (upvar). Attribute to these variables directly the default values that can be 793 # overwritten later with the new defined values. 794 upvar $Var Variable__$Var 795 796 # Set the flags to the default values only when the procedure is called interactively: 797 if {$ProcDef($ProcName,Arg,$Var,-type)=="none"} { 798 set Variable__$Var 0 799 } elseif {[info exists ProcDef($ProcName,Arg,$Var,-default)]} { 800 # Apply an eventually defined default value, in case the argument is not a flag: 801 set Variable__$Var $ProcDef($ProcName,Arg,$Var,-default) 802 } 803 } 804 805 # Prepare parsing all arguments 806 set NbrArgs [llength $args]; # Number of provided arguments 807 set NumberUnnamedArgs 0 808 set ArgPos 0 809 810 # Parse the unnamed arguments if they are defined first and if some of them have been 811 # declared: 812 if {!$ProcDef($ProcName,-named_arguments_first)} { 813 # Parse all unnamed arguments. Stop parsing them when: 814 # 1) all unnamed arguments that have been declared have been parsed && 815 # the last unnamed argument has not the -multiple option && 816 # 2) the parsed argument is optional and starts with '-' 817 # 3) the parsed argument has can take multiple values && 818 # one value has already been read && 819 # the parsed argument starts with '-' 820 821 # An argument value is optional when it has been declared with the -optional option 822 # or when it is declared with the -multiple option and already one value has been 823 # attributed to the argument: 824 set IsOptional 0 825 826 # Loop through all arguments (only if unnamed arguments have been declared: 827 for {} {$ArgPos<[llength $args] && $ProcDef($ProcName,NbrUnnamedVars)>0} {incr ArgPos} { 828 # Get the next provided parameter value: 829 set arg [lindex $args $ArgPos] 830 831 # The ordered unnamed argument list provides the relevant argument: 832 set Var [lindex $ProcDef($ProcName,UnnamedVarList) $NumberUnnamedArgs] 833 834 # Stop parsing the unnamed arguments, if the procedure has also named arguments, 835 # if the argument to parse is optional, and if it starts with '-': 836 if {$ProcDef($ProcName,Arg,$Var,-optional)} { 837 set IsOptional 1 838 } 839 if {$ProcDef($ProcName,NbrNamedVars)>0 && $IsOptional && \ 840 [string index $arg 0]=="-"} { 841 break 842 } 843 844 # If the argument can have multiple values: Don't update the unnamed argument 845 # counter to attribute the next values to the same argument. Declare the next 846 # values also as optional 847 if {$ProcDef($ProcName,Arg,$Var,-multiple)} { 848 lappend Variable__$Var $arg 849 set IsOptional 1 850 851 # Otherwise (the argument cannot have multiple values), assign the value to the 852 # variable. Exit the unnamed argument loop when the last declared argument has 853 # been read: 854 } else { 855 set Variable__$Var $arg 856 incr NumberUnnamedArgs 857 if {$NumberUnnamedArgs==$ProcDef($ProcName,NbrUnnamedVars)} { 858 incr ArgPos 859 break 860 } 861 } 862 } 863 864 # Create an error if there are other argument values that are provided, but when no 865 # named arguments are declared: 866 if {$ProcDef($ProcName,NbrNamedVars)==0 && $ArgPos<[llength $args]} { 867 ProcedureArgumentEvaluationReturn "$ProcName: Too many arguments: [lrange $args $ArgPos end]" 868 } 869 } 870 871 # Parse the named arguments 872 for {} {$ArgPos<[llength $args]} {incr ArgPos} { 873 # Get the argument name: 874 set arg [lindex $args $ArgPos] 875 876 # Ignore the '--' flag. Exit the named argument parsing loop if 'named arguments 877 # first' is configured 878 if {$arg=="--"} { 879 if {$ProcDef($ProcName,-named_arguments_first)} { 880 incr ArgPos 881 break 882 } else { 883 continue 884 } 885 } 886 887 # In case the named arguments are used first: Check if the next argument is not 888 # anymore a named argument and stop parsing the named arguments if this is the case. 889 if {$ProcDef($ProcName,-named_arguments_first) && [string index $arg 0]!="-"} { 890 break 891 } 892 893 # Otherwise (especially if the unnamed arguments are used first), check that the 894 # option name starts with '-': 895 if {[string index $arg 0]!="-"} { 896 ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '$arg' is not an option" 897 } 898 899 # Extract the variable name (eliminate the '-'): 900 set Var [string range $arg 1 end] 901 902 # Check if the variable (name) is known. When it is not known, complete it when the 903 # name matches with the begin of a known variable name, or generate otherwise an 904 # error: 905 if {![info exists ProcDef($ProcName,Arg,$Var,-type)]} { 906 907 # Argument completion is disabled - generate an error: 908 if {!$ProcDef($ProcName,-auto_argument_name_completion)} { 909 ProcedureArgumentEvaluationReturn "[PureProcName -appr]: Argument '-$Var' not known" 910 911 # Argument completion is enabled - check if the variable name corresponds to the 912 # begin of a known argument name: 913 } else { 914 # set MatchingVarList [lsearch -all -inline -glob $ProcDef($ProcName,VarList) ${Var}*] -> Tcl 8.3 doesn't support the -all and -inline switches! 915 set MatchingVarList {} 916 set VarList $ProcDef($ProcName,VarList) 917 while {[set Pos [lsearch -glob $VarList ${Var}*]]>=0} { 918 lappend MatchingVarList [lindex $VarList $Pos] 919 set VarList [lrange $VarList [expr $Pos+1] end] 920 } 921 # Complete the argument name if the argument doesn't exist, but if it is the begin of a declared argument. 922 switch [llength $MatchingVarList] { 923 1 {set Var $MatchingVarList} 924 0 {ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '-$Var' not known"} 925 default {ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '-$Var' may match multiple options: $MatchingVarList"} 926 } 927 } 928 } 929 930 # Set the variable value to '1' if the argument is a flag (type=='none'). Read 931 # otherwise the variable value: 932 if {$ProcDef($ProcName,Arg,$Var,-type)=="none"} { # The argument is a flag 933 set Value 1 934 935 # No argument value is provided - generate an error: 936 } elseif {$ArgPos==[llength $args]-1} { 937 ProcedureArgumentEvaluationReturn "[PureProcName]: No value is provided for argument '-$Var'" 938 939 # Read the argument value 940 } else { 941 set Value [lindex $args [incr ArgPos]] 942 } 943 944 # Define the argument variable. Append the new value to the existing value of the 945 # variable, if the '-multiple' attribute is set for the argument: 946 if {$ProcDef($ProcName,Arg,$Var,-multiple)} { 947 lappend Variable__$Var $Value 948 } else { 949 set Variable__$Var $Value 950 } 951 } 952 953 # In case the unnamed arguments are defined last, parse them now: 954 if {$ProcDef($ProcName,-named_arguments_first)} { 955 956 # Loop through the remaining arguments: 957 for {} {$ArgPos<[llength $args]} {incr ArgPos} { 958 # Get the next provided parameter value: 959 set arg [lindex $args $ArgPos] 960 # Assure that the number of provided arguments is not exceeding the total number 961 # of declared unnamed arguments: 962 if {$NumberUnnamedArgs>=$ProcDef($ProcName,NbrUnnamedVars)} { 963 # Too many unnamed arguments are used, generate an adequate error message: 964 if {[string index $arg 0]=="-"} { 965 ProcedureArgumentEvaluationReturn "[PureProcName]: Too many unnamed arguments, or incorrectly used named argument: $arg" 966 } else { 967 ProcedureArgumentEvaluationReturn "[PureProcName]: Too many unnamed arguments: $arg" 968 } 969 } 970 971 # The ordered unnamed argument list provides the relevant argument: 972 set Var [lindex $ProcDef($ProcName,UnnamedVarList) $NumberUnnamedArgs] 973 974 # Assign all remaining parameter values to the last argument if this one can 975 # take multiple values: 976 if {$ProcDef($ProcName,Arg,$Var,-multiple) && \ 977 $NumberUnnamedArgs==$ProcDef($ProcName,NbrUnnamedVars)-1} { 978 set Variable__$Var [lrange $args $ArgPos end] 979 # incr NumberUnnamedArgs 980 set ArgPos [llength $args] 981 982 # Assign otherwise the parameter value to the actual argument 983 } else { 984 set Variable__$Var $arg 985 incr NumberUnnamedArgs 986 } 987 } 988 } 989 } 990 991 #### Argument validation #### 992 993 # Check that all mandatory arguments have been defined and that all arguments satisfy the 994 # defined type: 995 996 # Loop through all named and unnamed arguments: 997 foreach Var $ProcDef($ProcName,VarList) { 998 999 # An error is created when a variable is not optional and when it is not defined: 1000 if {!$ProcDef($ProcName,Arg,$Var,-optional) && ![info exists Variable__$Var]} { 1001 ProcedureArgumentEvaluationReturn "[PureProcName]: Required argument is missing: $Var" 1002 } 1003 1004 # Check the variable value corresponds to the specified type: 1005 if {[info exists Variable__$Var]} { 1006 # Transform the variable value in a list in case the argument is not multiple 1007 # definable: 1008 set ValueList [set Variable__$Var] 1009 if {!$ProcDef($ProcName,Arg,$Var,-multiple)} { 1010 set ValueList [list $ValueList] 1011 } 1012 1013 # Loop through all elements of this list and check if each element is valid: 1014 foreach Value $ValueList { 1015 # Check the argument type: 1016 if {![Validate($ProcDef($ProcName,Arg,$Var,-type)) $Value]} { 1017 ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '$Var' requires type '$ProcDef($ProcName,Arg,$Var,-type)'. Provided value: '$Value'" 1018 } 1019 1020 # Check the argument with an eventually defined validation command: 1021 if {[info exists ProcDef($ProcName,Arg,$Var,-validatecommand)]} { 1022 regsub {%P} $ProcDef($ProcName,Arg,$Var,-validatecommand) $Value ValidateCommand 1023 if {![eval $ValidateCommand]} { 1024 ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '$Var' couldn't be validated by '$ProcDef($ProcName,Arg,$Var,-validatecommand)'. Provided value: '$Value'" 1025 } 1026 } 1027 1028 # Check if the variable value satisfies an eventually defined range: 1029 if {[info exists ProcDef($ProcName,Arg,$Var,-range)]} { 1030 if {$Value<[lindex $ProcDef($ProcName,Arg,$Var,-range) 0] || \ 1031 $Value>[lindex $ProcDef($ProcName,Arg,$Var,-range) 1]} { 1032 ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '$Var' has to be between [lindex $ProcDef($ProcName,Arg,$Var,-range) 0] and [lindex $ProcDef($ProcName,Arg,$Var,-range) 1]" 1033 } 1034 } 1035 1036 # Check the variable value is a member of a provided choice list: 1037 if {[info exists ProcDef($ProcName,Arg,$Var,-choices)]} { 1038 if {[lsearch -exact $ProcDef($ProcName,Arg,$Var,-choices) $Value]<0} { 1039 ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '$Var' has to be one of the following elements: [GetChoiceHelpText $ProcName $Var]" 1040 } 1041 } 1042 } 1043 } 1044 } 1045 1046 ProcedureArgumentEvaluationReturn "" 1047 } 1048 1049 ######## Validation commands ######## 1050 1051 # For each of the standard argument types supported by TEPAM, the validation command 1052 # 'Validate(<Type>) specified in the following section. These commands have to return '1' in 1053 # case the provided value correspond to the relevant type and '0' if not. Additional user or 1054 # application specific types can easily be supported simply by adding a validation command 1055 # for the new type into the 'tepam' namespace. 1056 1057 proc Validate() {v} {return 1} 1058 proc Validate(none) {v} {return 1} 1059 proc Validate(string) {v} {return 1} 1060 proc Validate(boolean) {v} {expr [string length $v]>0 && [string is boolean $v]} 1061 proc Validate(double) {v} {expr [string length $v]>0 && [string is double $v]} 1062 proc Validate(integer) {v} {expr [string length $v]>0 && [string is integer $v]} 1063 proc Validate(alnum) {v} {string is alnum $v} 1064 proc Validate(alpha) {v} {string is alpha $v} 1065 proc Validate(ascii) {v} {string is ascii $v} 1066 proc Validate(control) {v} {string is control $v} 1067 proc Validate(digit) {v} {string is digit $v} 1068 proc Validate(graph) {v} {string is graph $v} 1069 proc Validate(lower) {v} {string is lower $v} 1070 proc Validate(print) {v} {string is print $v} 1071 proc Validate(punct) {v} {string is punct $v} 1072 proc Validate(space) {v} {string is space $v} 1073 proc Validate(upper) {v} {string is upper $v} 1074 proc Validate(wordchar) {v} {string is wordchar $v} 1075 proc Validate(xdigit) {v} {string is xdigit $v} 1076 proc Validate(char) {v} {expr [string length $v]==1} 1077 proc Validate(color) {v} {expr ![catch {winfo rgb . $v}]} 1078 proc Validate(font) {v} {expr ![catch {font measure $v ""}]} 1079 proc Validate(file) {v} {expr [string length $v]>0 && ![regexp {[\"*?<>]} $v]} 1080 proc Validate(existingfile) {v} {file exists $v} 1081 proc Validate(directory) {v} {return 1} 1082 proc Validate(existingdirectory) {v} {file isdirectory $v} 1083 1084 ######## Help text generation ######## 1085 1086 # 'ProcedureHelp_Append' appends a piece of text to the existing HelpText variable of the 1087 # calling context (procedure). Tabulator characters are replaced through 3 spaces. Lines are 1088 # reformatted to respect the maximum allowed line length. In case a line is wrapped, the leading 1089 # spaces of the first line are added to the begin of the following lines. Multiple lines can be 1090 # provided as text piece and these multiple lines are handled independently each to another. 1091 1092 proc ProcedureHelp_Append {Text} { 1093 upvar HelpText HelpText 1094 variable help_line_length 1095 1096 # Replace tabs through 3 spaces: 1097 regsub -all {\t} $Text " " Text 1098 1099 # Extract the initial spaces of the first line: 1100 regexp {^(\s*)} $Text {} SpaceStart 1101 1102 # Loop through each of the provided help text line: 1103 foreach line [split $Text "\n"] { 1104 1105 # Eliminate leading spaces of the line: 1106 regexp {^\s+'*(.*)$} $line {} line 1107 1108 # Cut the line into segments that doesn't exceed the maximum allowed help line length. 1109 # Add in front of each new line the initial spaces of the first line: 1110 while {$line!=""} { 1111 # Align the leading line spaces to the first line: 1112 set line ${SpaceStart}${line} 1113 1114 #### Next line cutoff position evaluation #### 1115 1116 # Select the next line cut position. The default position is set to the line end: 1117 set LastPos [string length $line] 1118 # Search for the last space inside the line section that is inside the specified 1119 # maximum line length: 1120 if {$LastPos>$help_line_length} { 1121 set LastPos [string last " " $line $help_line_length] 1122 } 1123 # If the evaluated line break position is inside the range of the initial line spaces, 1124 # something goes wrong and the line should be broken at another adequate character: 1125 if {$LastPos<=[string length $SpaceStart]-1} { 1126 # Search for other good line break characters (: 1127 set LastPos [lindex [lindex \ 1128 [regexp -inline -indices {[^,:\.?\)]+$} \ 1129 {ProcDef(::ImportTestPointAssignmentsGeneric,Arg_SectionComment,ColumnSeparation}] 0] 0] 1130 # No line break position could be found: 1131 if {$LastPos=={}} {set LinePos 0} 1132 } 1133 # Break the line simply at the maximum allowed length in case no break position could 1134 # be found: 1135 if {$LastPos<=[string length $SpaceStart]-1} {set LastPos $help_line_length} 1136 1137 # Add the line segment to the help text: 1138 append HelpText [string range $line 0 [expr $LastPos-1]]\n 1139 1140 # Eliminate the segment from the actual line: 1141 set line [string range $line [expr $LastPos+1] end] 1142 } 1143 } 1144 } 1145 1146 # GetChoiceHelpText returns a help test for the choice options. The returned string corresponds 1147 # to the comma separated choice list in case no choice labels are defined. Otherwise, the 1148 # choice labels are added behind the choice options in paranthesis. 1149 1150 proc GetChoiceHelpText {ProcName Var} { 1151 variable ProcDef 1152 set ChoiceHelpText "" 1153 set LabelList {} 1154 catch {set LabelList $ProcDef($ProcName,Arg,$Var,-choicelabels)} 1155 foreach Choice $ProcDef($ProcName,Arg,$Var,-choices) Label $LabelList { 1156 append ChoiceHelpText ", $Choice" 1157 if {$Label!=""} { 1158 append ChoiceHelpText "($Label)" 1159 } 1160 } 1161 return [string range $ChoiceHelpText 2 end] 1162 } 1163 1164 # 'ProcedureHelp' behaves in different ways, depending the provided argument. Called without any 1165 # argument, it summarizes all the declared procedures without explaining details about the 1166 # procedure arguments. Called with a particular procedure name as parameter, it produces for 1167 # this procedure a comprehensive help text. And finally, if it is called with the name of a main 1168 # procedure that has multiple sub procedures, it generates for all the sub procedures the 1169 # complete help text. 1170 1171 proc ProcedureHelp {{ProcName ""} {ReturnHelp 0}} { 1172 variable ProcDef 1173 variable ProcedureList 1174 ProcedureHelp_Append "NAME" 1175 1176 # Print a list of available commands when no procedure name has been provided as argument: 1177 if {$ProcName==""} { 1178 foreach ProcName [lsort -dictionary $ProcedureList] { 1179 if {[info exists ProcDef($ProcName,-short_description)]} { 1180 ProcedureHelp_Append " [PureProcName] - $ProcDef($ProcName,-short_description)" 1181 } else { 1182 ProcedureHelp_Append " [PureProcName]" 1183 } 1184 } 1185 1186 # A procedure name has been provided, generate a detailed help text for this procedure, or 1187 # for all sub procedures if only the main procedure names has been provided: 1188 } else { 1189 # Evaluate the complete main procedure name that contains the namespace identification: 1190 # Check if the procedure name contains already the name space identification: 1191 if {[string range $ProcName 0 1]!="::"} { 1192 # The namespace is not part of the used procedure name call. Evaluate it explicitly: 1193 set NameSpace [uplevel 1 {namespace current}] 1194 if {$NameSpace!="::"} {append NameSpace "::"} 1195 set ProcName ${NameSpace}${ProcName} 1196 } 1197 1198 # Add the short description if it exists to the NAME help text section. Please note that 1199 # only the short description of a main procedure is used in case the procedure has also 1200 # sub procedures. 1201 if {[info exists ProcDef($ProcName,-short_description)]} { 1202 ProcedureHelp_Append " [PureProcName] - $ProcDef($ProcName,-short_description)" 1203 } else { 1204 ProcedureHelp_Append " [PureProcName]" 1205 } 1206 1207 # Create the SYNOPSIS section which contains also the synopsis of eventual sub procedures: 1208 ProcedureHelp_Append "SYNOPSIS" 1209 set NbrDescriptions 0 1210 set NbrExamples 0 1211 1212 # Loop through all procedures and sub procedures: 1213 set ProcNames [lsort -dictionary [concat [list $ProcName] [info procs "$ProcName *"]]] 1214 foreach ProcName $ProcNames { 1215 # Skip the (sub) procedure if it has not been explicitly declared. This may be the 1216 # case for procedures that are not implemented themselves but which have sub procedures: 1217 if {![info exists ProcDef($ProcName,VarList)]} continue 1218 1219 # Add to the help text first the procedure name, and then in the following lines its 1220 # arguments: 1221 ProcedureHelp_Append " [PureProcName]" 1222 foreach NamedUnnamed {Named Unnamed} { 1223 foreach Var $ProcDef($ProcName,${NamedUnnamed}VarList) { 1224 # Section comment: Create a clean separation of the arguments: 1225 if {[info exists ProcDef($ProcName,Arg,$Var,SectionComment)]} { 1226 ProcedureHelp_Append " --- $ProcDef($ProcName,Arg,$Var,SectionComment) ---" 1227 } 1228 1229 # Argument declaration - put optional arguments into brackets, show the name 1230 # of named arguments, add existing descriptions as well as range, type, choice 1231 # definitions: 1232 set HelpLine " " 1233 if {$ProcDef($ProcName,Arg,$Var,-optional)} { 1234 append HelpLine "\[" 1235 } 1236 if {$ProcDef($ProcName,Arg,$Var,IsNamed)} { 1237 append HelpLine "-$Var " 1238 } 1239 if {$ProcDef($ProcName,Arg,$Var,-type)!="none"} { 1240 append HelpLine "<$Var>" 1241 } 1242 if {$ProcDef($ProcName,Arg,$Var,-optional)} { 1243 append HelpLine "\]" 1244 } 1245 ProcedureHelp_Append $HelpLine 1246 1247 set HelpLine " " 1248 if {[info exists ProcDef($ProcName,Arg,$Var,-description)]} { 1249 append HelpLine "$ProcDef($ProcName,Arg,$Var,-description), " 1250 } 1251 if {[lsearch -exact {"" "none"} $ProcDef($ProcName,Arg,$Var,-type)]<0} { 1252 append HelpLine "type: $ProcDef($ProcName,Arg,$Var,-type), " 1253 } 1254 if {[info exists ProcDef($ProcName,Arg,$Var,-default)]} { 1255 if {[lsearch -exact {"" "string"} $ProcDef($ProcName,Arg,$Var,-type)]>=0} { 1256 append HelpLine "default: \"$ProcDef($ProcName,Arg,$Var,-default)\", " 1257 } else { 1258 append HelpLine "default: $ProcDef($ProcName,Arg,$Var,-default), " 1259 } 1260 } 1261 if {[info exists ProcDef($ProcName,Arg,$Var,-range)]} { 1262 append HelpLine "range: [lindex $ProcDef($ProcName,Arg,$Var,-range) 0]..[lindex $ProcDef($ProcName,Arg,$Var,-range) 1], " 1263 } 1264 if {[info exists ProcDef($ProcName,Arg,$Var,-choices)]} { 1265 append HelpLine "choices: \{[GetChoiceHelpText $ProcName $Var]\}, " 1266 } 1267 # Eliminate the last ", ": 1268 ProcedureHelp_Append [string range $HelpLine 0 end-2] 1269 } 1270 } 1271 # Remember if descriptions and/or examples are provided for the procedure: 1272 if {[info exists ProcDef($ProcName,-description)]} { 1273 incr NbrDescriptions 1274 } 1275 if {[info exists ProcDef($ProcName,-example)]} { 1276 incr NbrExamples 1277 } 1278 } 1279 # Add for the procedure and sub procedures the descriptions: 1280 if {$NbrDescriptions>0} { 1281 ProcedureHelp_Append "DESCRIPTION" 1282 foreach ProcName $ProcNames { 1283 if {[info exists ProcDef($ProcName,-description)]} { 1284 if {[llength $ProcNames]>1} { 1285 ProcedureHelp_Append " [PureProcName]" 1286 ProcedureHelp_Append " $ProcDef($ProcName,-description)" 1287 } else { 1288 ProcedureHelp_Append " $ProcDef($ProcName,-description)" 1289 } 1290 } 1291 } 1292 } 1293 # Add for the procedure and sub procedures the examples: 1294 if {$NbrExamples>0} { 1295 ProcedureHelp_Append "EXAMPLE" 1296 foreach ProcName $ProcNames { 1297 if {[info exists ProcDef($ProcName,-example)]} { 1298 if {[llength $ProcNames]>1} { 1299 ProcedureHelp_Append " [PureProcName]" 1300 ProcedureHelp_Append " $ProcDef($ProcName,-example)" 1301 } else { 1302 ProcedureHelp_Append " $ProcDef($ProcName,-example)" 1303 } 1304 } 1305 } 1306 } 1307 } 1308 # The created help text is by default printed to stdout. The text will be returned 1309 # as result when 'ReturnHelp' is set to 1: 1310 if {$ReturnHelp} { 1311 return $HelpText 1312 } else { 1313 puts $HelpText 1314 } 1315 } 1316 1317########################################################################## 1318# argument_dialogbox # 1319########################################################################## 1320 1321 ######## Argument_dialogbox configuration ######## 1322 1323 # Application specific entry widget procedures can use this array variable to store their own 1324 # data, using as index the widget path provided to the procedure, e.g. 1325 # argument_dialogbox($W,<sub_index>): 1326 array set argument_dialogbox {} 1327 1328 # Special elements of this array variable can be specified for testing purposes: 1329 # 1330 # Set to following variable to 0 to "emulate" an acknowledge of the dialog box and to 3 to 1331 # "emulate" an activation of the Cancel button: 1332 set argument_dialogbox(test,status) "" 1333 1334 # The following variable can contain a script that is executed for test purposes, before 1335 # the argument dialog box waits on user interactions. The script is executed in the context 1336 # of the argument dialog box. Entire user interaction actions can be emulated together 1337 # with the previous variable. 1338 set argument_dialogbox(test,script) {} 1339 1340 # The array variable 'last_parameters' is only used by an argument dialog box when its context 1341 # has been specified via the -context attribute. The argument dialog box' position and size as 1342 # well as its entered data are stored inside this variable when the data are acknowledged and 1343 # the form is closed. This allows the form to restore its previous state once it is called 1344 # another time. 1345 array set last_parameters {} 1346 1347 1348 ######## Argument_dialogbox help text ######## 1349 1350 set ArgumentDialogboxHelp { 1351 argument_dialogbox \ 1352 [-title <DialogBoxTitle>] 1353 [-window <DialogBoxWindow>] 1354 [-context <DialogBoxContext>] 1355 <ArgumentDefinition>|<FrameDefinition>|<Comment> 1356 [<ArgumentDefinition>|<FrameDefinition>|<Separation>|<Comment>] 1357 [<ArgumentDefinition>|<FrameDefinition>|<Separation>|<Comment>] 1358 ... 1359 1360 <FrameDefinition> = -frame <FrameLabel> 1361 1362 <Separation> = -sep {} 1363 1364 <Comment> = -comment {-text <text>} 1365 1366 <ArgumentDefinition> = 1367 <ArgumentWidgetType> 1368 { 1369 [-variable <variable>] 1370 [-label <LabelName>] 1371 [-choices <ChoiceList>] 1372 [-choicelabels <ChoiceLabelList>] 1373 [-choicevariable <ChoiceVariable>] 1374 [-default <DefaultValue>] 1375 [-multiple_selection 0|1] 1376 [-height <Height>] 1377 [<WidgetTypeParameter1> <WidgetTypeParameterValue1>] 1378 [<WidgetTypeParameter2> <WidgetTypeParameterValue2>] 1379 ... 1380 } 1381 1382 <ParameterWidgetType> = <StandardParameterWidgetType>|<ApplicationSpecificParameterWidgetType> 1383 1384 <StandardParameterWidgetType> = { 1385 -entry 1386 -checkbox -radiobox -checkbutton 1387 -listbox -disjointlistbox -combobox 1388 -file -existingfile -directory -existingdirectory 1389 -color -font 1390 } 1391 } 1392 1393 # Eliminate leading tabs in the help text and replace eventual tabs through spaces 1394 regsub -all -line {^\t\t} $ArgumentDialogboxHelp "" ArgumentDialogboxHelp 1395 regsub -all -line {\t} $ArgumentDialogboxHelp " " ArgumentDialogboxHelp 1396 1397 ######## argument_dialogbox ######## 1398 1399 # The argument dialog box allows a very easy generation of complex dialog boxes that can be 1400 # used for tool configuration purposes or to control actions. 1401 # The argument dialog box accepts only named arguments, e.g. all arguments have to be defined 1402 # as argument pairs (-<ArgumentName> <ArgumentValue>). There are some view arguments like -title, 1403 # -windows and -context that effect the argument dialog box' general attitude and embedding. The 1404 # remaining argument block's objective is the definition of variables. Except the two arguments 1405 # -frame and -sep that are used to structure graphically the form, all other arguments have to 1406 # be assigned either to a local or global variable. The argument dialog box will create in the 1407 # procedure from which it has been called a local variable, unless the variable has not been 1408 # defined explicitly as global variable, or as part of a certain namespace. 1409 # The argument dialog box requires for each variable that has to be controlled a separate 1410 # parameter pair. The first element is indicating the entry form that will be used to control 1411 # the variable, the second element provides information concerning the variable that has to be 1412 # defined and about its validation as well as parameters for the entry form. TEPAM provides 1413 # already a lot of available entry forms, but other application specific forms can easily been 1414 # added if necessary. 1415 # The following lines show an example of the way how the argument dialog box is used: 1416 # 1417 # argument_dialogbox \ 1418 # -title "System configuration" \ 1419 # -window .dialog_box \ 1420 # -context test_1 \ 1421 # \ 1422 # -frame {-label "File definitions"} \ 1423 # -comment {-text "Here are two entry fields"} \ 1424 # -file {-variable InputFile} \ 1425 # -file {-label "Output file" -variable OutputFile} \ 1426 # -frame {-label "Frame2"} \ 1427 # -entry {-label Offset -variable OffsetValue} \ 1428 # -sep {} \ 1429 # -listbox {-label MyListBox -variable O(-lb1) -choices {1 2 3 4 5 6 7 8} -choicevariable ::O(-lb1_contents) -multiple_selection 1} \ 1430 # -frame {-label "Check and radio boxes"} \ 1431 # -checkbox {-label MyCheckBox -variable O(-check1) -choices {bold italic underline} -choicelabels {Bold Italic Underline}} \ 1432 # -radiobox {-label MyRadioBox -variable O(-radio1) -choices {bold italic underline} -choicelabels {Bold Italic Underline}} \ 1433 # -checkbutton {-label MyCheckButton -variable O(-check2)} \ 1434 # -frame {-label "Others"} \ 1435 # -color {-label "Background color" -variable MyColor} \ 1436 1437 proc argument_dialogbox {args} { 1438 variable argument_dialogbox 1439 variable ArgumentDialogboxHelp 1440 variable last_parameters 1441 # Call an initialization command that generates eventual required images: 1442 GuiEnvironmentInit 1443 1444 #### Basic parameter check #### 1445 1446 # Use the args' first element as args list if args contains only one element: 1447 if {[llength $args]==1} { 1448 set args [lindex $args 0] 1449 } 1450 # Check if arguments are provided and if the number of arguments is even: 1451 if {[llength $args]<1} { 1452 return -code error "argument_dialogbox: no argument is provided" 1453 } 1454 if {[llength $args]%2!=0 && $args!="-help"} { 1455 return -code error "argument_dialogbox: arguments have to be provided in key/value pairs" 1456 } 1457 1458 #### Global parameter evaluation and top-level window creation #### 1459 1460 # The following default widget path can be changed with the -window argument: 1461 set WParent . 1462 set Wtop .dialog 1463 set Title "Dialog" 1464 1465 # Apply the global parameters by looping through all arguments to select the relevant 1466 # ones: 1467 foreach {ArgName ArgValue} $args { 1468 switch -- $ArgName { 1469 -window {set Wtop $ArgValue} 1470 -parent {set WParent $ArgValue} 1471 -context {set Context $ArgValue} 1472 -title {set Title $ArgValue} 1473 -help {puts $ArgumentDialogboxHelp; return} 1474 } 1475 } 1476 1477 # Create the dialog box' top-level window. Hide it until the windows has been entirely 1478 # deployed: 1479 catch {destroy $Wtop} 1480 toplevel $Wtop 1481 wm withdraw $Wtop 1482 wm title $Wtop $Title 1483 wm transient $Wtop $WParent 1484 1485 # Delete eventually variables defined by a previous call of the argument dialog box: 1486 catch {array unset argument_dialogbox $Wtop,*} 1487 catch {array unset argument_dialogbox $Wtop.*} 1488 1489 #### Argument dependent dialog box generation #### 1490 1491 # Loop through all arguments and build the dialog box: 1492 set ArgNbr -1 1493 set Framed 0 1494 set W $Wtop 1495 foreach {ArgName ArgValue} $args { 1496 incr ArgNbr 1497 1498 # Check that the argument is a named argument: 1499 if {[string index $ArgName 0]!="-"} { 1500 return -code error "Argument $ArgName not known" 1501 } 1502 1503 # Skip the items that have already been processed 1504 if {[lsearch -exact {-window -parent -context -title -help} $ArgName]>=0} continue 1505 1506 # Define the widget path for the new argument: 1507 set WChild($ArgNbr) $W.child_$ArgNbr 1508 1509 # An argument option array will be created, based on the argument value list: 1510 if {$ArgName!="-sep"} { 1511 catch {unset Option} 1512 array set Option {-label "" -optional 0} 1513 if {[llength $ArgValue]%2!=0} { 1514 return -code error "argument_dialogbox, argument $ArgName: Attribute definition list has to contain an even number of elements" 1515 } 1516 array set Option $ArgValue 1517 } 1518 1519 # The leading '-' of the argument name will not be used anymore in the remaining code: 1520 set ElementType [string range $ArgName 1 end] 1521 switch -- $ElementType { 1522 frame { 1523 # Handle frames - close an eventual already open frame first: 1524 if {$Framed} { 1525 set W [winfo parent [winfo parent $W]] 1526 set WChild($ArgNbr) $W.child_$ArgNbr 1527 } 1528 set Framed 0 1529 1530 # Create only a new frame when the provided argument list is not empty: 1531 if {$ArgValue!=""} { 1532 # Create a labeled frame (for Tk 8.3 that doesn't contain a label frame) 1533 set FontSize 10 1534 pack [frame $WChild($ArgNbr) -bd 0] \ 1535 -pady [expr $FontSize/2] -fill both -expand no 1536 pack [frame $WChild($ArgNbr).f -bd 2 -relief groove] \ 1537 -pady [expr $FontSize/2] -fill both -expand no 1538 place [label $WChild($ArgNbr).label -text $Option(-label)] \ 1539 -x $FontSize -y [expr $FontSize/2] -anchor w 1540 pack [canvas $WChild($ArgNbr).f.space -height [expr $FontSize/4] -width 10] \ 1541 -pady 0 1542 set W $WChild($ArgNbr).f 1543 set Framed 1 1544 } 1545 } 1546 1547 sep { 1548 # A separator is nothing else than a frame widget that has 'no height' and a 1549 # relief structure: 1550 pack [frame $WChild($ArgNbr) -height 2 -borderwidth 1 -relief sunken] \ 1551 -fill x -expand no -pady 4 1552 } 1553 1554 comment { 1555 # A simple label widget is used for comments: 1556 pack [label $WChild($ArgNbr) -text $Option(-text) -fg blue -justify left] \ 1557 -anchor w -expand no -pady 2 1558 } 1559 1560 default { 1561 # All other arguments, e.g. the real entries to define the variables, are 1562 # handled by procedures that provides sub commands for the different usages: 1563 # ad_form(<EntryType>) create - creates the entry widget 1564 # ad_form(<EntryType>) set_choice - set the choice constraints 1565 # ad_form(<EntryType>) set - set the default value 1566 # ad_form(<EntryType>) get - read the defined value 1567 1568 # Create a text in front of the entry widget if the -text attribute is defined: 1569 if {[info exists Option(-text)]} { 1570 pack [label $WChild($ArgNbr)_txt -text $Option(-text) -fg blue \ 1571 -justify left] -anchor w -expand no -pady 2 1572 } 1573 1574 # Create for the entry a frame and place the label together with a sub frame 1575 # into it: 1576 pack [frame $WChild($ArgNbr)] -fill x -expand yes 1577 pack [label $WChild($ArgNbr).label -text $Option(-label)] -pady 4 -side left 1578 pack [frame $WChild($ArgNbr).f] -fill x -expand yes -side left 1579 1580 # Delete eventual existing array members related to the new entry: 1581 array unset argument_dialogbox $WChild($ArgNbr),* 1582 1583 # Create the variable entry form: 1584 ad_form($ElementType) $WChild($ArgNbr).f create 1585 1586 # Attribute if existing the choice list. This list can either be provided via 1587 # the -choicevariable or via -choices: 1588 if {[info exists Option(-choicevariable)] && \ 1589 [uplevel 1 "info exists \"$Option(-choicevariable)\""]} { 1590 ad_form($ElementType) $WChild($ArgNbr).f set_choice \ 1591 [uplevel 1 "set \"$Option(-choicevariable)\""] 1592 } elseif {[info exists Option(-choices)]} { 1593 ad_form($ElementType) $WChild($ArgNbr).f set_choice $Option(-choices) 1594 } 1595 1596 # Apply the default value. If the variable exists already, use the variable value 1597 # as default value. Otherwise, check if the last_parameter array provides the 1598 # value from a previous usage. And finally, check if a default value is provided 1599 # via the -default option: 1600 if {[info exists Option(-variable)] && \ 1601 [uplevel 1 "info exists \"$Option(-variable)\""]} { 1602 ad_form($ElementType) $WChild($ArgNbr).f set \ 1603 [uplevel 1 "set \"$Option(-variable)\""] 1604 } elseif {[info exists Option(-variable)] && [info exists Context] && \ 1605 [info exists last_parameters($Context,$Option(-variable))]} { 1606 ad_form($ElementType) $WChild($ArgNbr).f set \ 1607 $last_parameters($Context,$Option(-variable)) 1608 } elseif {[info exists Option(-default)]} { 1609 ad_form($ElementType) $WChild($ArgNbr).f set $Option(-default) 1610 } 1611 1612 # Check if the 'Validate' command is defined for the provided variable type: 1613 if {[info exists Option(-type)] && [catch {Validate($Option(-type)) ""}]} { 1614 return -code error "Argument_dialogbox: Argument type '$Option(-default)' not known" 1615 } 1616 } 1617 } 1618 } 1619 1620 #### Dialog box finalization #### 1621 1622 # Finalize the dialog box - Add the OK and cancel buttons, restore eventually saved 1623 # geometry data and deiconify finally the form: 1624 pack [frame $Wtop.buttons] -fill x -expand no 1625 button $Wtop.buttons.ok -text OK -command "set ::tepam::argument_dialogbox($Wtop,status) ok" 1626 button $Wtop.buttons.cancel -text Cancel -command "set ::tepam::argument_dialogbox($Wtop,status) cancel" 1627 pack $Wtop.buttons.ok $Wtop.buttons.cancel -side left -fill x -expand yes 1628 if {[info exists Context] && [info exists last_parameters($Context,-geometry)]} { 1629 wm geometry $Wtop $last_parameters($Context,-geometry) 1630 } 1631 wm protocol $Wtop WM_DELETE_WINDOW "set ::tepam::argument_dialogbox($Wtop,status) cancel" 1632 wm deiconify $Wtop 1633 1634 #### Wait until the dialog box's entries are approved or discarded # 1635 1636 # Execute a test script if required 1637 if {$argument_dialogbox(test,script)!={}} { 1638 eval $argument_dialogbox(test,script) 1639 } 1640 1641 # Stay in a loop until all the provided values have been validated: 1642 while {1} { 1643 1644 # Wait until the OK or cancel button is pressed: 1645 set argument_dialogbox($Wtop,status) "" 1646 if {$argument_dialogbox(test,status)==""} { 1647 vwait ::tepam::argument_dialogbox($Wtop,status) 1648 set status $argument_dialogbox($Wtop,status) 1649 } else { # Emulate the button activation for test purposes 1650 set status $argument_dialogbox(test,status) 1651 } 1652 # Cancel has been pressed - exit the wait loop: 1653 if {$status=="cancel"} break 1654 1655 # Read all the provided values, validate them, and assign them the corresponding 1656 # variables: 1657 set ErrorMessage "" 1658 set ArgNbr -1 1659 foreach {ArgName ArgValue} $args { 1660 incr ArgNbr 1661 1662 # Extract the element type (eliminate the leading '-') and the parameters to the 1663 # Option array: 1664 set ElementType [string range $ArgName 1 end] 1665 if {[llength $ArgValue]<2 || [llength $ArgValue]%2!=0} continue 1666 catch {unset Option} 1667 array set Option {-label "" -optional 0} 1668 array set Option $ArgValue 1669 # No variable is assigned to the entry, so skip this parameter: 1670 if {![info exists Option(-variable)]} continue 1671 1672 # Read the result, check it and assign the result variable 1673 set Value [ad_form($ElementType) $WChild($ArgNbr).f get] 1674 1675 # Validate the provided data: 1676 if {$Value!="" || $Option(-optional)==0} { 1677 if {[info exists Option(-type)] && ![Validate($Option(-type)) $Value]} { 1678 append ErrorMessage "$Option(-variable): Required type is $Option(-type)\n" 1679 } 1680 # Apply the validate command if existing: 1681 if {[info exists Option(-validatecommand)]} { 1682 regsub {%P} $Option(-validatecommand) $Value ValidateCommand 1683 if {![eval $ValidateCommand]} { 1684 append ErrorMessage "$Option(-variable): The value '$Value' is not valid\n" 1685 } 1686 } 1687 # Check against a provided range: 1688 if {[info exists Option(-range)]} { 1689 if {$Value<[lindex $Option(-range) 0] || \ 1690 $Value>[lindex $Option(-range) 1]} { 1691 append ErrorMessage "$Option(-variable): The value has to be between [lindex $Option(-range) 0] and [lindex $Option(-range) 1]\n" 1692 } 1693 } 1694 # Check that the variable value is a member of a provided choice list. Some 1695 # flexibility is required for this check, since the specified value may be a list 1696 # of multiple elements that are matching the choice list. 1697 if {[info exists Option(-choices)]} { 1698 set ChoiceError 0 1699 foreach v $Value { 1700 if {[lsearch -exact $Option(-choices) $v]<0} { 1701 incr ChoiceError 1702 } 1703 } 1704 if {$ChoiceError && [lsearch -exact $Option(-choices) $Value]<0} { 1705 append ErrorMessage "$Option(-variable): The value(s) has(have) to be one of the following elements: $Option(-choices)\n" 1706 } 1707 } 1708 } 1709 if {[info exists Context]} { 1710 set last_parameters($Context,$Option(-variable)) $Value 1711 } 1712 } 1713 # Generate an error message box if errors have been logged: 1714 if {$ErrorMessage!=""} { 1715 if {$argument_dialogbox(test,status)==""} { 1716 tk_messageBox -icon error -title Error -type ok -parent $Wtop \ 1717 -message "The entries could not be successfully validated:\n\n$ErrorMessage\nPlease correct the related entries." 1718 raise $Wtop 1719 } else { # Return the error message as error for test purposes 1720 return -code error "The entries could not be successfully validated:\n\n$ErrorMessage\nPlease correct the related entries." 1721 } 1722 } else { 1723 # Everything could be validated, exit the wait loop: 1724 break 1725 } 1726 } 1727 1728 #### Assign the values to the variables #### 1729 1730 if {$status=="ok"} { 1731 set ArgNbr -1 1732 foreach {ArgName ArgValue} $args { 1733 incr ArgNbr 1734 # Extract the element type (eliminate the leading '-') and the parameters to the 1735 # Option array: 1736 set ElementType [string range $ArgName 1 end] 1737 if {[llength $ArgValue]<2 || [llength $ArgValue]%2!=0} continue 1738 catch {unset Option} 1739 array set Option {-label "" -optional 0} 1740 array set Option $ArgValue 1741 # No variable is assigned to the entry, so skip this parameter: 1742 if {![info exists Option(-variable)]} continue 1743 1744 # Read the result, check it and assign the result variable 1745 set Value [ad_form($ElementType) $WChild($ArgNbr).f get] 1746 1747 # Define the variable in the context of the calling procedure: 1748 if {$Value!="" || $Option(-optional)==0} { 1749 uplevel 1 "set \"$Option(-variable)\" \{$Value\}" 1750 } 1751 } 1752 } 1753 1754 #### Save the dialog box' geometry and destroy the form #### 1755 1756 if {[info exists Context]} { 1757 set last_parameters($Context,-geometry) [wm geometry $Wtop] 1758 } 1759 destroy $Wtop 1760 array unset argument_dialogbox $Wtop,* 1761 return $status 1762 } 1763 1764 # Create the necessary resources when the argument dialog box is called the first time: 1765 proc GuiEnvironmentInit {} { 1766 if {[lsearch [image names] Tepam_SmallFlashDown]>=0} return 1767 image create bitmap Tepam_SmallFlashDown -data {#define down_width 8 1768 #define down_height 8 1769 static unsigned char down_bits[] = { 1770 0x00 0x00 0xff 0x7e 0x3c 0x18 0x00 0x00 }; } 1771 } 1772 1773 ######## Standard entry forms for the argument_dialogbox ######## 1774 1775 # A dedicated procedure that handles the geometrical aspects of the argument dialog box is 1776 # required for each argument type. The prototype header of such a procedure is: 1777 # 1778 # proc ad_form(<EntryType>) {W Command {Par ""}} <Body> 1779 # 1780 # The argument 'W' provides the path into which the entry has to be embedded. 1781 # The procedures have to provide several sub command. The optional argument 'Par' is only used 1782 # for the 'set' and 'set_choice' sub commands: 1783 # 1784 # ad_form(<EntryType>) <W> create 1785 # This sub command has to creates the form for the given entry type. 1786 # 1787 # ad_form(<EntryType>) <W> set_choice <ChoiceList> 1788 # This sub command has to define the available selections (choice lists). 1789 # 1790 # ad_form(<EntryType>) <W> set <Value> 1791 # This sub command has to set the default value of the form. 1792 # 1793 # ad_form(<EntryType>) <W> get 1794 # This sub command has to return the value defined inside the form. 1795 # 1796 # To support all these sub commands, the procedures are typically structured in the following 1797 # way: 1798 # 1799 # proc ad_form(<EntryType>) {W Command {Par ""}} { 1800 # upvar Option Option 1801 # switch $Command { 1802 # "create" {<Form creation script>} 1803 # "set" {<Default value setting script>} 1804 # "set_choice" {<Choice list definition script>} 1805 # "get" {return [<Value evaluation script>]} 1806 # } 1807 # } 1808 # 1809 # The parameter definition list is mapped to the Option array variable when the ad_form 1810 # procedures are called. These procedures can access these parameters via the Option variable 1811 # of the calling procedure using the upvar statement. 1812 # The provided frame into which each ad_form procedure can deploy the argument definition entry 1813 # is by default not expandable. To make them expandable, for example for list boxes, the 1814 # procedure ad_form(make_expandable) has to be called providing it with the entry path: 1815 1816 proc ad_form(make_expandable) {W} { 1817 upvar 2 Framed Framed FontSize FontSize 1818 # Override the not expanded parent frames: 1819 pack $W -fill both -expand yes 1820 pack [winfo parent $W] -fill both -expand yes 1821 if {$Framed} { 1822 # Make the parent frames expandable for that the listbox can also expand 1823 pack [winfo parent [winfo parent [winfo parent $W]]] \ 1824 -pady [expr $FontSize/2] -fill both -expand yes 1825 pack [winfo parent [winfo parent $W]] \ 1826 -pady [expr $FontSize/2] -fill both -expand yes 1827 } 1828 } 1829 1830 # Implement now all entries: 1831 1832 #### Simple text entry #### 1833 1834 proc ad_form(entry) {W Command {Par ""}} { 1835 switch $Command { 1836 "create" { 1837 pack [entry $W.entry] -fill x -expand yes -pady 4 -side left } 1838 "set" { 1839 $W.entry delete 0 end; # Clear the existing selection in case the 'set' command is called multiple times 1840 $W.entry insert 0 $Par 1841 } 1842 "get" { 1843 return [$W.entry get] 1844 } 1845 } 1846 } 1847 1848 #### Color entry #### 1849 1850 # Select_color sets the text and color of the color entry to a new color: 1851 proc select_color {W NewColor} { 1852 if {$NewColor!=""} { 1853 $W.entry delete 0 end 1854 $W.entry insert 0 $NewColor 1855 } 1856 $W.entry config -background gray80 1857 catch {$W.entry config -background [$W.entry get]} 1858 } 1859 1860 proc ad_form(color) {W Command {Par ""}} { 1861 upvar Option Option 1862 if {![info exists Option(-type)]} { 1863 set Option(-type) color 1864 } 1865 set Title "" 1866 catch {set Title $Option(-label)} 1867 switch $Command { 1868 "create" { 1869 pack [entry $W.entry] -fill x -expand yes -pady 4 -side left 1870 pack [button $W.button -text Choose -command "::tepam::select_color $W \[tk_chooseColor -parent \{$W\} -title \{$Title\}\]"] -pady 4 -side left 1871 bind $W.entry <Key-Return> "tepam::select_color $W {}" 1872 bind $W.entry <Leave> "tepam::select_color $W {}" 1873 } 1874 "set" { 1875 select_color $W $Par 1876 } 1877 "get" { 1878 return [$W.entry get] 1879 } 1880 } 1881 } 1882 1883 #### File and directory entries #### 1884 1885 # Select_file sets the file or directory entry to a new file name: 1886 proc select_file {W NewFile} { 1887 if {$NewFile==""} return 1888 $W.entry delete 0 end 1889 $W.entry insert 0 $NewFile 1890 } 1891 1892 # Ad_form(directory_or_file) is a generic implementation of a file and directory selection 1893 # form. It will be used for the different file and directory types: 1894 proc ad_form(directory_or_file) {W Type Command {Par ""}} { 1895 upvar 2 Option Option 1896 if {![info exists Option(-type)]} { 1897 set Option(-type) $Type 1898 } 1899 set Title "" 1900 catch {set Title $Option(-label)} 1901 switch $Command { 1902 "create" { 1903 set FileTypes {} 1904 if {[info exists Option(-filetypes)]} { 1905 set FileTypes $Option(-filetypes) 1906 } 1907 1908 set ActiveDir "\[file dirname \[$W.entry get\]\]"; 1909 if {[info exists Option(-activedir)]} { 1910 set ActiveDir $Option(-activedir) 1911 } 1912 1913 set InitialFile "\[$W.entry get\]"; 1914 if {[info exists Option(-initialfile)]} { 1915 set InitialFile $Option(-initialfile) 1916 set ActiveDir [file dirname $Option(-initialfile)] 1917 } 1918 1919 pack [entry $W.entry] -fill x -expand yes -pady 4 -side left 1920 if {$Type=="existingdirectory"} { 1921 pack [button $W.button -text Browse -command "::tepam::select_file $W \[tk_chooseDirectory -parent $W -initialdir \"$ActiveDir\" -title \{$Title\}\]"] -pady 4 -side left 1922 } elseif {$Type=="directory"} { 1923 pack [button $W.button -text Browse -command "::tepam::select_file $W \[tk_chooseDirectory -parent $W -initialdir \"$ActiveDir\" -title \{$Title\}\]"] -pady 4 -side left 1924 } elseif {$Type=="existingfile"} { 1925 pack [button $W.button -text Browse -command "::tepam::select_file $W \[tk_getOpenFile -parent $W -filetypes \{$FileTypes\} -initialdir \"$ActiveDir\" -initialfile \"$InitialFile\" -title \{$Title\}\]"] -pady 4 -side left 1926 } else { # file 1927 pack [button $W.button -text Browse -command "::tepam::select_file $W \[tk_getSaveFile -parent $W -filetypes \{$FileTypes\} -initialdir \"$ActiveDir\" -initialfile \"$InitialFile\" -title \{$Title\}\]"] -pady 4 -side left 1928 } 1929 } 1930 "set" { 1931 $W.entry delete 0 end; # Clear the existing selection in case the 'set' command is called multiple times 1932 $W.entry insert 0 $Par 1933 } 1934 "get" { 1935 return [$W.entry get] 1936 } 1937 } 1938 } 1939 1940 # The generic file and directory selection command 'ad_form(directory_or_file)' are used to 1941 # implement the 4 file and directory selection forms: 1942 1943 proc ad_form(directory) {W Command {Par ""}} { 1944 ad_form(directory_or_file) $W directory $Command $Par 1945 } 1946 1947 proc ad_form(existingdirectory) {W Command {Par ""}} { 1948 ad_form(directory_or_file) $W existingdirectory $Command $Par 1949 } 1950 1951 proc ad_form(file) {W Command {Par ""}} { 1952 ad_form(directory_or_file) $W file $Command $Par 1953 } 1954 1955 proc ad_form(existingfile) {W Command {Par ""}} { 1956 ad_form(directory_or_file) $W existingfile $Command $Par 1957 } 1958 1959 #### Combobox #### 1960 1961 proc ad_form(combobox) {W Command {Par ""}} { 1962 switch $Command { 1963 "create" { 1964 pack [entry $W.entry -borderwidth 2] -fill x -expand yes -pady 4 -side left 1965 pack [button $W.button -relief flat -borderwidth 0 -image Tepam_SmallFlashDown -command "tepam::ad_form(combobox) $W open_selection"] -pady 4 -side left 1966 1967 toplevel $W.selection -border 1 -background black 1968 wm overrideredirect $W.selection 1 1969 wm withdraw $W.selection 1970 pack [listbox $W.selection.listbox -yscrollcommand "$W.selection.scrollbar set" -exportselection 0] -fill both -expand yes -side left 1971 pack [scrollbar $W.selection.scrollbar -command "$W.selection.listbox yview"] -fill y -side left -expand no 1972 1973 bind $W.selection.listbox <<ListboxSelect>> "tepam::ad_form(combobox) $W close_selection" 1974 bind $W.selection <FocusOut> "wm withdraw $W.selection" 1975 } 1976 "set" { 1977 $W.entry delete 0 end; # Clear the existing selection in case the 'set' command is called multiple times 1978 $W.entry insert 0 $Par 1979 } 1980 "get" { 1981 return [$W.entry get] 1982 } 1983 "set_choice" { 1984 foreach v $Par { 1985 $W.selection.listbox insert end $v 1986 } 1987 } 1988 "open_selection" { 1989 wm geometry $W.selection [expr [winfo width $W.entry]+[winfo width $W.button]]x100+[winfo rootx $W.entry]+[expr [winfo rooty $W.entry]+[winfo height $W.entry]] 1990 1991 catch {$W.selection.listbox selection clear 0 end} 1992 catch {$W.selection.listbox selection set [lsearch -exact [$W.selection.listbox get 0 end] [$W.entry get]]} 1993 catch {$W.selection.listbox yview [lsearch -exact [$W.selection.listbox get 0 end] [$W.entry get]]} 1994 1995 wm deiconify $W.selection 1996 focus $W.selection } 1997 "close_selection" { 1998 $W.entry delete 0 end 1999 $W.entry insert 0 [$W.selection.listbox get [$W.selection.listbox curselection]] 2000 wm withdraw $W.selection } 2001 } 2002 } 2003 2004 #### Listbox #### 2005 2006 proc ad_form(listbox) {W Command {Par ""}} { 2007 # puts "ad_form(listbox) $W $Command $Par" 2008 upvar Option Option 2009 switch $Command { 2010 "create" { 2011 ad_form(make_expandable) $W 2012 pack [listbox $W.listbox -yscrollcommand "$W.scrollbar set" -exportselection 0] -fill both -expand yes -pady 4 -side left 2013 if {[info exists Option(-multiple_selection)] && $Option(-multiple_selection)} { 2014 $W.listbox config -selectmode extended 2015 } 2016 pack [scrollbar $W.scrollbar -command "$W.listbox yview"] -fill y -pady 4 -side left -expand no 2017 if {[info exists Option(-height)]} { 2018 $W.listbox config -height $Option(-height) 2019 } 2020 } 2021 "set" { 2022 catch {$W.listbox selection clear 0 end}; # Clear the existing selection in case the 'set' command is called multiple times 2023 if {[info exists Option(-multiple_selection)] && $Option(-multiple_selection)} { 2024 foreach o $Par { 2025 catch {$W.listbox selection set [lsearch -exact [$W.listbox get 0 end] $o]} 2026 catch {$W.listbox yview [lsearch -exact [$W.listbox get 0 end] $o]} 2027 } 2028 } else { 2029 catch {$W.listbox selection set [lsearch -exact [$W.listbox get 0 end] $Par]} 2030 catch {$W.listbox yview [lsearch -exact [$W.listbox get 0 end] $Par]} 2031 } 2032 } 2033 "get" { 2034 set Result {} 2035 foreach o [$W.listbox curselection] { 2036 lappend Result [$W.listbox get $o] 2037 } 2038 if {![info exists Option(-multiple_selection)] || !$Option(-multiple_selection)} { 2039 set Result [lindex $Result 0] 2040 } 2041 return $Result 2042 } 2043 "set_choice" { 2044 foreach v $Par { 2045 $W.listbox insert end $v 2046 } 2047 $W.listbox selection set 0 2048 } 2049 } 2050 } 2051 2052 #### Disjoint listbox #### 2053 2054 proc disjointlistbox_move {W Move} { 2055 switch $Move { 2056 "add" { 2057 foreach o [lsort -integer -increasing [$W.listbox1 curselection]] { 2058 $W.listbox2 insert end [$W.listbox1 get $o] 2059 } 2060 foreach o [lsort -integer -decreasing [$W.listbox1 curselection]] { 2061 $W.listbox1 delete $o 2062 } 2063 } 2064 "delete" { 2065 foreach o [lsort -integer -increasing [$W.listbox2 curselection]] { 2066 $W.listbox1 insert end [$W.listbox2 get $o] 2067 } 2068 foreach o [lsort -integer -decreasing [$W.listbox2 curselection]] { 2069 $W.listbox2 delete $o 2070 } 2071 } 2072 "up" { 2073 foreach o [$W.listbox2 curselection] { 2074 if {$o==0} continue 2075 $W.listbox2 insert [expr $o-1] [$W.listbox2 get $o] 2076 $W.listbox2 delete [expr $o+1] 2077 $W.listbox2 selection set [expr $o-1] 2078 } 2079 } 2080 "down" { 2081 foreach o [lsort -integer -decreasing [$W.listbox2 curselection]] { 2082 if {$o==[$W.listbox2 index end]-1} continue 2083 $W.listbox2 insert [expr $o+2] [$W.listbox2 get $o] 2084 $W.listbox2 delete $o 2085 $W.listbox2 selection set [expr $o+1] 2086 } 2087 } 2088 } 2089 } 2090 2091 proc ad_form(disjointlistbox) {W Command {Par ""}} { 2092 # puts "ad_form(listbox) $W $Command $Par" 2093 upvar Option option 2094 switch $Command { 2095 "create" { 2096 ad_form(make_expandable) $W 2097 2098 grid [label $W.label1 -text "Available"] -column 1 -row 0 -sticky ew 2099 grid [label $W.label2 -text "Selected"] -column 3 -row 0 -sticky ew 2100 2101 grid [listbox $W.listbox1 -yscrollcommand "$W.scrollbar1 set" -exportselection 0 -selectmode extended] -column 1 -row 1 -rowspan 2 -sticky news 2102 grid [scrollbar $W.scrollbar1 -command "$W.listbox1 yview"] -column 2 -row 1 -rowspan 2 -sticky ns 2103 grid [listbox $W.listbox2 -yscrollcommand "$W.scrollbar2 set" -exportselection 0 -selectmode extended] -column 3 -row 1 -rowspan 2 -sticky news 2104 grid [scrollbar $W.scrollbar2 -command "$W.listbox2 yview"] -column 4 -row 1 -rowspan 2 -sticky ns 2105 2106 grid [button $W.up -text "^" -command "::tepam::disjointlistbox_move $W up"] -column 5 -row 1 -sticky ns 2107 grid [button $W.down -text "v" -command "::tepam::disjointlistbox_move $W down"] -column 5 -row 2 -sticky ns 2108 2109 grid [button $W.add -text ">" -command "::tepam::disjointlistbox_move $W add"] -column 1 -row 3 -columnspan 2 -sticky ew 2110 grid [button $W.remove -text "<" -command "::tepam::disjointlistbox_move $W delete"] -column 3 -row 3 -columnspan 2 -sticky ew 2111 2112 foreach {Col Weight} {0 0 1 1 2 0 3 1 4 0 5 0} { 2113 grid columnconfigure $W $Col -weight $Weight 2114 } 2115 grid rowconfigure $W 1 -weight 1 2116 grid rowconfigure $W 2 -weight 1 2117 if {[info exists Option(-height)]} { 2118 $W.listbox1 config -height $Option(-height) 2119 $W.listbox2 config -height $Option(-height) 2120 } 2121 } 2122 "set" { 2123 # Delete an eventually previous selection (this should not be required by argument_dialogox) 2124 $W.listbox2 selection set 0 end 2125 disjointlistbox_move $W delete 2126 2127 foreach o $Par { 2128 $W.listbox2 insert end $o 2129 set p [lsearch -exact [$W.listbox1 get 0 end] $o] 2130 if {$p>=0} { # Delete the selected item from the available items 2131 $W.listbox1 delete $p 2132 } 2133 } 2134 } 2135 "get" { 2136 return [$W.listbox2 get 0 end] 2137 } 2138 "set_choice" { 2139 foreach v $Par { 2140 $W.listbox1 insert end $v 2141 } 2142 } 2143 } 2144 } 2145 2146 #### Checkbox #### 2147 2148 proc ad_form(checkbox) {W Command {Par ""}} { 2149 upvar Option Option 2150 variable argument_dialogbox 2151 switch $Command { 2152 "create" { 2153 set argument_dialogbox($W,ButtonsW) {} 2154 } 2155 "set" { 2156 # Delete an eventually previous selection 2157 foreach ChoiceIndex [array names argument_dialogbox $W,values,*] { 2158 set argument_dialogbox($ChoiceIndex) "" 2159 } 2160 # Select the check buttons that correspond to the provided values 2161 foreach v $Par { 2162 foreach BW $argument_dialogbox($W,ButtonsW) { 2163 if {$v==[$BW cget -onvalue]} { 2164 set [$BW cget -variable] $v 2165 } 2166 } 2167 } 2168 } 2169 "get" { # Provide the selected items in the order of the provided choice list 2170 set Result {} 2171 foreach ChoiceIndex [lsort -dictionary [array names argument_dialogbox $W,values,*]] { 2172 if {$argument_dialogbox($ChoiceIndex)!=""} { 2173 lappend Result $argument_dialogbox($ChoiceIndex) } 2174 } 2175 return $Result 2176 } 2177 "set_choice" { 2178 set ChoiceNumber -1 2179 foreach v $Par { 2180 set label $v 2181 catch {set label [lindex $Option(-choicelabels) $ChoiceNumber]} 2182 pack [checkbutton $W.choice_[incr ChoiceNumber] -text $label -variable ::tepam::argument_dialogbox($W,values,$ChoiceNumber) -onvalue [lindex $v 0] -offvalue ""] -side left 2183 lappend argument_dialogbox($W,ButtonsW) $W.choice_$ChoiceNumber 2184 } 2185 } 2186 } 2187 } 2188 2189 #### Radiobox #### 2190 2191 proc ad_form(radiobox) {W Command {Par ""}} { 2192 variable argument_dialogbox 2193 switch $Command { 2194 "create" { 2195 set argument_dialogbox($W,values) "" 2196 } 2197 "set" { 2198 set argument_dialogbox($W,values) $Par 2199 } 2200 "get" { 2201 return $argument_dialogbox($W,values) 2202 } 2203 "set_choice" { 2204 set argument_dialogbox($W,values) [lindex [lindex $Par 0] 0] 2205 set ChoiceNumber -1 2206 foreach v $Par { 2207 set label $v 2208 catch {set label [lindex $Option(-choicelabels) $ChoiceNumber]} 2209 pack [radiobutton $W.choice_[incr ChoiceNumber] -text $label -variable ::tepam::argument_dialogbox($W,values) -value [lindex $v 0]] -side left 2210 } 2211 } 2212 } 2213 } 2214 2215 #### Checkbutton #### 2216 2217 proc ad_form(checkbutton) {W Command {Par ""}} { 2218 variable argument_dialogbox 2219 switch $Command { 2220 "create" { 2221 pack [checkbutton $W.checkb -variable ::tepam::argument_dialogbox($W,values)] -pady 4 -side left 2222 set argument_dialogbox($W,values) 0 2223 } 2224 "set" { 2225 set argument_dialogbox($W,values) $Par 2226 } 2227 "get" { 2228 return $argument_dialogbox($W,values) 2229 } 2230 } 2231 } 2232 2233 #### Font selector #### 2234 2235 proc ChooseFont_Update {W} { 2236 catch {$W.text config -font [ChooseFont_Get $W]} 2237 } 2238 2239 proc ChooseFont_Get {W} { 2240 set Result {} 2241 if {![catch {lappend Result [$W.sels.lb_font get [$W.sels.lb_font curselection]] [$W.sels.lb_size get [$W.sels.lb_size curselection]]}]} { 2242 foreach Style {bold italic underline overstrike} { 2243 if {$::tepam::ChooseFont($W,$Style)} { 2244 lappend Result $Style 2245 } 2246 } 2247 } 2248 # puts Font:$Result 2249 return $Result 2250 } 2251 2252 procedure ChooseFont { 2253 -args { 2254 {-title -type string -default "Font browser"} 2255 {-parent -type string -default "."} 2256 {-font_families -type string -default {}} 2257 {-font_sizes -type string -default {}} 2258 {-default -type string -optional} 2259 } 2260 } { 2261 regexp {^\.*(\..*)$} $parent.font_selection {} W 2262 catch {destroy $W} 2263 toplevel $W 2264 wm withdraw $W 2265 wm transient $W $parent 2266 wm group $W $parent 2267 wm title $W $title 2268 2269 pack [label $W.into -text "Please choose a font and its size \nand style, then select OK." -justify left] -expand no -fill x 2270 2271 pack [frame $W.sels] -expand yes -fill both 2272 pack [listbox $W.sels.lb_font -yscrollcommand "$W.sels.sb_font set" -exportselection 0 -height 10] -side left -expand yes -fill both 2273 bind $W.sels.lb_font <<ListboxSelect>> "::tepam::ChooseFont_Update $W" 2274 pack [scrollbar $W.sels.sb_font -command "$W.sels.lb_font yview"] -side left -expand no -fill both 2275 pack [listbox $W.sels.lb_size -yscrollcommand "$W.sels.sb_size set" -width 3 -exportselection 0 -height 10] -side left -expand no -fill both 2276 bind $W.sels.lb_size <<ListboxSelect>> "::tepam::ChooseFont_Update $W" 2277 pack [scrollbar $W.sels.sb_size -command "$W.sels.lb_size yview"] -side left -expand no -fill both 2278 2279 set ButtonFont [font actual [[button $W.dummy] cget -font]] 2280 pack [frame $W.styles] -expand no -fill x 2281 pack [checkbutton $W.styles.bold -text B -indicatoron off -font "$ButtonFont -weight bold" -variable ::tepam::ChooseFont($W,bold) -command "::tepam::ChooseFont_Update $W"] -side left -expand yes -fill x 2282 pack [checkbutton $W.styles.italic -text I -indicatoron off -font "$ButtonFont -slant italic" -variable ::tepam::ChooseFont($W,italic) -command "::tepam::ChooseFont_Update $W"] -side left -expand yes -fill x 2283 pack [checkbutton $W.styles.underline -text U -indicatoron off -font "$ButtonFont -underline 1" -variable ::tepam::ChooseFont($W,underline) -command "::tepam::ChooseFont_Update $W"] -side left -expand yes -fill x 2284 pack [checkbutton $W.styles.overstrike -text O -indicatoron off -font "$ButtonFont -overstrike 1" -variable ::tepam::ChooseFont($W,overstrike) -command "::tepam::ChooseFont_Update $W"] -side left -expand yes -fill x 2285 2286 pack [label $W.text -text "Test text 1234"] -expand no -fill x 2287 2288 pack [frame $W.buttons] -expand no -fill x 2289 pack [button $W.buttons.ok -text OK -command "set ::tepam::ChooseFont($W,status) 0"] -side left -expand yes -fill x 2290 pack [button $W.buttons.cancel -text Cancel -command "set ::tepam::ChooseFont($W,status) 3"] -side left -expand yes -fill x 2291 2292 # Create the font size and family lists. Use default lists when no family or sizes 2293 # are provided. 2294 if {$font_families=={}} { 2295 set font_families [font families] 2296 } 2297 foreach v $font_families { 2298 $W.sels.lb_font insert end $v 2299 } 2300 2301 if {$font_sizes=={}} { 2302 set font_sizes {6 7 8 9 10 12 14 16 18 20 24 28 32 36 40} 2303 } 2304 foreach v $font_sizes { 2305 $W.sels.lb_size insert end $v 2306 } 2307 2308 # Set the default font selection 2309 if {![info exists default]} { 2310 set default [$W.text cget -font] 2311 # puts "default:$default" 2312 } 2313 2314 set Index [lsearch -exact $font_families [lindex $default 0]] 2315 if {$Index<0} {set Index [lsearch -exact $font_families [font actual $default -family]]} 2316 if {$Index<0} {set Index 0} 2317 # puts "[font actual $default -family] -> $Index" 2318 $W.sels.lb_font selection clear 0 end 2319 $W.sels.lb_font selection set $Index 2320 $W.sels.lb_font yview $Index 2321 2322 set Index [lsearch -exact $font_sizes [lindex $default 0]] 2323 if {$Index<0} {set Index [lsearch -exact $font_sizes [font actual $default -size]]} 2324 if {$Index<0} {set Index 0} 2325 # puts "[font actual $default -size] -> $Index" 2326 $W.sels.lb_size selection clear 0 end 2327 $W.sels.lb_size selection set $Index 2328 $W.sels.lb_size yview $Index 2329 2330 foreach Style {bold italic underline overstrike} { 2331 set ::tepam::ChooseFont($W,$Style) 0 2332 } 2333 foreach Style [lrange $default 2 end] { 2334 if {[info exists ::tepam::ChooseFont($W,$Style)]} { 2335 set ::tepam::ChooseFont($W,$Style) 1 2336 } 2337 } 2338 2339 wm protocol $W WM_DELETE_WINDOW "set ::tepam::ChooseFont($W,status) 3" 2340 wm geometry $W "+[expr [winfo rootx $parent]+[winfo width $parent]+10]+[expr [winfo rooty $parent]+0]" 2341 wm deiconify $W 2342 2343 # Wait until the OK or cancel button is pressed: 2344 set ::tepam::ChooseFont($W,status) "" 2345 vwait ::tepam::ChooseFont($W,status) 2346 2347 set SelectedFont [ChooseFont_Get $W] 2348 destroy $W 2349 if {$::tepam::ChooseFont($W,status)==0} {return $SelectedFont} 2350 return "" 2351 } 2352 2353 # Select_font sets the text and the font of the font entry to a font color: 2354 proc select_font {W NewFont} { 2355 variable argument_dialogbox 2356 if {$NewFont!=""} { 2357 $W.entry delete 0 end 2358 $W.entry insert 0 $NewFont 2359 } 2360 $W.entry config -bg gray80 2361 catch { 2362 $W.entry config -font [$W.entry get] 2363 $W.entry config -bg $argument_dialogbox($W,DefaultEntryColor) 2364 } 2365 } 2366 2367 proc ad_form(font) {W Command {Par ""}} { 2368 upvar Option Option 2369 variable argument_dialogbox 2370 if {![info exists Option(-type)]} { 2371 set Option(-type) font 2372 } 2373 set Title "" 2374 catch {set Title $Option(-label)} 2375 switch $Command { 2376 "create" { 2377 # The dedicated attributes -font_families and -font_sizes by this entry widget: 2378 set FamilyList [font families] 2379 catch {set FamilyList $Option(-font_families)} 2380 2381 set SizeList {6 7 8 9 10 12 14 16 18 20 24 28 32 36 40} 2382 catch {set SizeList $Option(-font_sizes)} 2383 2384 # Create the entry widget 2385 pack [entry $W.entry] -fill x -expand yes -pady 4 -side left 2386 pack [button $W.button -text Choose \ 2387 -command "::tepam::select_font $W \[::tepam::ChooseFont -parent \{$W\} -title \{$Title\} -font_families \{$FamilyList\} -font_sizes \{$SizeList\} -default \[$W.entry get\]\]"] -pady 4 -side left 2388 bind $W.entry <Key-Return> "tepam::select_font $W {}" 2389 bind $W.entry <Leave> "tepam::select_font $W {}" 2390 2391 set argument_dialogbox($W,DefaultEntryColor) [$W.entry cget -bg] 2392 2393 # Use the default font of the entry widget as default font selection if its font 2394 # family and font size is part of the selection lists. Use otherwise the first 2395 # elements of the family list and the closest size for the default font. 2396 set DefaultFont [$W.entry cget -font] 2397 2398 set DefaultFamily [font actual $DefaultFont -family] 2399 if {[lsearch -exact $FamilyList $DefaultFamily]<0} { 2400 set DefaultFamily [lindex $FamilyList 0] 2401 } 2402 2403 set DefaultSize [font actual $DefaultFont -size] 2404 if {[lsearch -exact $SizeList $DefaultSize]<0} { 2405 set SizeList [lsort -real [concat $SizeList $DefaultSize]] 2406 set Pos [lsearch -exact $SizeList $DefaultSize] 2407 if {$Pos==0} { 2408 set DefaultSize [lindex $SizeList 1] 2409 } elseif {$Pos==[llength $SizeList]-1} { 2410 set DefaultSize [lindex $SizeList end-1] 2411 } elseif {[lindex $SizeList $Pos]-[lindex $SizeList [expr $Pos-1]] < 2412 [lindex $SizeList [expr $Pos+1]]-[lindex $SizeList $Pos] } { 2413 set DefaultSize [lindex $SizeList [expr $Pos-1]] 2414 } else { 2415 set DefaultSize [lindex $SizeList [expr $Pos+1]] 2416 } 2417 } 2418 2419 select_font $W [list $DefaultFamily $DefaultSize] 2420 } 2421 "set" { 2422 select_font $W $Par 2423 } 2424 "get" { 2425 return [$W.entry get] 2426 } 2427 } 2428 } 2429 2430}; # End namespace tepam 2431 2432# Specify the TEPAM version that is provided by this file: 2433package provide tepam $::tepam::version 2434 2435