Annotation of capa/capa51/GUITools/common.tcl, revision 1.9

1.1       albertel    1: set gMaxSet 99
                      2: ###########################################################
                      3: # capaRaise
                      4: ###########################################################
                      5: # tries to make sure that the window mostly definatley ends
                      6: # up on top. Needed to do this beacuase of how an Xserver 
                      7: # for WinNT handles raise
                      8: ###########################################################
                      9: # Argument: window - name of the window to get on top
                     10: # Returns : nothing
                     11: # Globals : nothing
                     12: ###########################################################
                     13: proc capaRaise { window } {
                     14:     if { $window == "" } { return }
                     15:     wm withdraw $window
                     16:     wm deiconify $window
                     17: #    raise $window
                     18: }
                     19: 
                     20: ###########################################################
                     21: # cleanWindowList
                     22: ###########################################################
                     23: ###########################################################
                     24: ###########################################################
                     25: proc cleanWindowList { } {
                     26:     global gWindowMenu gCmd gUndoSize gUndo
                     27: 
                     28:     set gCmd "Tcl Commands executed: [info cmdcount]" 
                     29:     catch {set gUndoSize "Undo information size [array size gUndo]:[string length [array get gUndo]]"}
                     30:     if { ![winfo exists $gWindowMenu] } {
                     31: 	after 1000 cleanWindowList
                     32: 	return
                     33:     }
                     34:     set num [$gWindowMenu index end]
                     35:     for { set i 1 } { $i <= $num } { incr i } {
                     36: 	set window [lindex [$gWindowMenu entrycget $i -command] 1]
                     37: 	if { ![winfo exists $window] } { 
                     38: 	    $gWindowMenu delete $i
                     39: 	    incr i -1
                     40: 	    set num [$gWindowMenu index end]
                     41: 	}
                     42:     }
                     43:     after 1000 cleanWindowList
                     44: }
                     45: 
                     46: ###########################################################
                     47: # createRemapWindow
                     48: ###########################################################
                     49: # creates the window to start the process of remapping or unmapping 
                     50: # the xKeySym for a key
                     51: ###########################################################
                     52: # Argument: none
                     53: # Returns: nothing
                     54: # Globals: gWindowMenu - used to register the window under the windows
                     55: #                        menu
                     56: ###########################################################
                     57: proc createRemapWindow {} {
                     58:     global gWindowMenu
                     59: 
                     60:     if { [winfo exists .remap] } {
                     61: 	capaRaise .remap 
                     62: 	return
                     63:     }
                     64: 
                     65:     set remap [toplevel .remap]
                     66:     $gWindowMenu add command -label "Remap" -command "capaRaise $remap"
                     67:     wm title $remap "Select Remap Command"
                     68: 
                     69:     label $remap.label -text "This requires that xmodmap be in your path"
                     70:     button $remap.delete -text "Remap a key to delete" -command \
                     71: 	    "remap Delete
                     72:              destroy $remap
                     73:              removeWindowEntry Remap"
                     74:     button $remap.backspace -text "Remap a key to backspace" -command \
                     75: 	    "remap BackSpace
                     76:              destroy $remap
                     77:              removeWindowEntry Remap"
                     78:     button $remap.unmap -text "Unmap a remapped key" -command \
                     79: 	    "remap unmap
                     80:              destroy $remap
                     81:              removeWindowEntry Remap"
                     82:     button $remap.cancel -text "Cancel" -command \
                     83:             "destroy $remap
                     84:              removeWindowEntry Remap"
                     85:     pack $remap.label $remap.delete $remap.backspace $remap.unmap \
                     86: 	    $remap.cancel -side top
                     87: 
                     88:     Centre_Dialog $remap default
                     89: }
                     90: 
                     91: ###########################################################
                     92: # remap
                     93: ###########################################################
                     94: # creates a window thaat tells the user to press a key, which globally
                     95: # grabs input, and the runs xmodmap to a file it creates in /tmp named
                     96: # gkc[pid].
                     97: ###########################################################
                     98: # Arguments: one of (Delete,Backspace,unmap), type of remap to preform
                     99: # Returns: nothing
                    100: # Globals: gOriginalKeySyms - stores the KeySyms and keycodes of
                    101: #                             remmapped keys.
                    102: #          gPromptRemap - used to capture the keypress by the user.
                    103: # Files: /tmp/gkc[pid] - stores inforamtion to be run through xmodmap 
                    104: #                        (created and removed)
                    105: ###########################################################
                    106: proc remap { type } {
                    107:     global gOriginalKeySyms gPromptRemap
                    108: 
                    109:     set gPromptRemap(result) ""
                    110: 
                    111:     switch $type {
                    112: 	Delete
                    113: 	-
                    114: 	BackSpace
                    115: 	{
                    116: 	    set dialog [toplevel .dialog]
                    117: 	    wm title $dialog "Grabbing keypress"
                    118: 	    label $dialog.label -text "Press the key that you want to remap \
                    119: 		    to $type" 
                    120: 	    label $dialog.label2 -textvariable gPromptRemap(result)
                    121: 	    pack $dialog.label $dialog.label2
                    122: 	    
                    123: 	    bind all <KeyPress> "set gPromptRemap(result) \"%k %K\""
                    124: 	    Centre_Dialog $dialog default
                    125: 	    capaRaise $dialog
                    126: 	    focus $dialog
                    127: 	    grab -global $dialog
                    128: 	    vwait gPromptRemap(result)
                    129: 	    grab release $dialog
                    130: 	    destroy $dialog
                    131: 	    bind all <KeyPress> ""
                    132: 	    set oldKeyCode [lindex $gPromptRemap(result) 0]
                    133: 	    set oldKeySym [lindex $gPromptRemap(result) 1]
                    134: 	    set error [catch { set a $gOriginalKeySyms($oldKeyCode) } ]
                    135: 	    if { $error == 1 } {
                    136: 		set gOriginalKeySyms($oldKeyCode) $oldKeySym
                    137: 	    }
                    138: 	    exec echo "keycode $oldKeyCode = $type" > [ file join / tmp \
                    139: 		    gkc[pid] ]
                    140: 	    exec xmodmap [ file join / tmp gkc[pid] ]
                    141: 	    displayMessage "Remapped $oldKeySym to $type"
                    142: 	}
                    143: 	unmap
                    144: 	{
                    145: 	    set dialog [toplevel .dialog]
                    146: 	    wm title $dialog "Grabbing keypress"
                    147: 	    label $dialog.label -text "Press the key that you want to unmap" 
                    148: 	    label $dialog.label2 -textvariable gPromptRemap(result)
                    149: 	    pack $dialog.label $dialog.label2
                    150: 	    
                    151: 	    bind all <KeyPress> "set gPromptRemap(result) \"%k %K\""
                    152: 	    Centre_Dialog $dialog default
                    153: 	    capaRaise $dialog
                    154: 	    focus $dialog
                    155: 	    grab -global $dialog
                    156: 	    vwait gPromptRemap(result)
                    157: 	    grab release $dialog
                    158: 	    destroy $dialog
                    159: 	    bind all <KeyPress> ""
                    160: 	    set oldKeyCode [lindex $gPromptRemap(result) 0]
                    161: 	    set oldKeySym [lindex $gPromptRemap(result) 1]
                    162: 	    set error [catch { set a $gOriginalKeySyms($oldKeyCode) } ]
                    163: 	    if { $error == 1 } {
                    164: 		displayMessage "Sorry, $oldKeySym has not been remapped \
                    165: 			since Quizzer has been started."
                    166: 	    } else {
                    167: 		exec echo "keycode $oldKeyCode = \
                    168: 			$gOriginalKeySyms($oldKeyCode)" > \
                    169: 			[ file join / tmp gkc[pid] ]
                    170: 		exec xmodmap [ file join / tmp gkc[pid] ]
                    171: 		displayMessage "Remapped $oldKeySym back to \
                    172: 		    $gOriginalKeySyms($oldKeyCode) "
                    173: 	    }
                    174: 	}
                    175:     }
                    176:     catch { rm -f [file join / tmp gkc*]}
                    177: }
                    178: 
                    179: ###########################################################
                    180: # unmapAllKeys
                    181: ###########################################################
                    182: # wanders through the gOriginalKeySyms var and unmap individually
                    183: # all of the keys that had been remmapped
                    184: ###########################################################
                    185: # Arguments: none
                    186: # Returns: nothing
                    187: # Globals: gOriginalKeySyms - stores the original KeySym values by
                    188: #                             keycodes that have been remmapped
                    189: # Files: /tmp/gkc[pid] - stores inforamtion to be run through xmodmap 
                    190: #                        (created and removed)
                    191: ###########################################################
                    192: proc unmapAllKeys { } {
                    193:     global gOriginalKeySyms
                    194: 
                    195:     set allKeyCodes [array names gOriginalKeySyms]
                    196:     
                    197:     while { $allKeyCodes != "" } {
                    198: 	set oldKeyCode [lindex $allKeyCodes 0]
                    199: 	set allKeyCodes [lrange $allKeyCodes 1 end]
                    200: 	exec echo "keycode $oldKeyCode = $gOriginalKeySyms($oldKeyCode)" \
                    201: 		> [ file join / tmp gkc[pid] ]
                    202: 	exec xmodmap [ file join / tmp gkc[pid] ]
                    203: 	catch { rm -rf [ file join / tmp gkc*] }
                    204:     }
                    205:     #displayMessage "Remapped all keys back to original value."
                    206: }
                    207: 
                    208: 
                    209: ###########################################################
                    210: # displayError
                    211: ###########################################################
                    212: # displays a modal dialog with an errormessage to the user
                    213: ###########################################################
                    214: # Arguments: the message to be displayed
                    215: # Returns: Nothing
                    216: # Globals: gPromptDE - used to detect when the user presses ok
                    217: ###########################################################
                    218: proc displayError { msg {color black} } {
                    219:     global gPromptDE
                    220: 
                    221:     set dialog [toplevel .prompt -borderwidth 10]
                    222:     wm geo $dialog "+200+200"
                    223:     wm title $dialog "Error"
                    224: 
                    225:     message $dialog.warning -text "WARNING" -font 12x24 -aspect 700
                    226:     message $dialog.msg -text "$msg" -aspect 700 -foreground $color
                    227:     set buttonFrame [frame $dialog.buttons -bd 10]
                    228:     pack $dialog.warning $dialog.msg $buttonFrame -side top -fill x
                    229:     
                    230:     button $buttonFrame.ok -text Dismiss -command { set gPromptDE(ok) 1 } \
                    231: 	    -underline 0
                    232:     pack $buttonFrame.ok -side left
                    233:    
                    234:     Centre_Dialog $dialog default 
                    235:     update
                    236: 
                    237:     capaRaise $dialog
                    238:     focus $dialog
                    239:     capaGrab $dialog
                    240:     vwait gPromptDE(ok)
                    241:     capaGrab release $dialog
                    242:     destroy $dialog
                    243:     return
                    244: }
                    245: 
                    246: ###########################################################
                    247: # capaGrab
                    248: ###########################################################
                    249: # modification of tcl's grab, this one sets up a binding so that
                    250: # if you click anywhere else the window is reshuffled back to the
                    251: # top
                    252: ###########################################################
                    253: # Arguments: either "window" or "release window"
                    254: # Returns: Nothing
                    255: # Globals: None
                    256: ###########################################################
                    257: proc capaGrab { args } {
                    258:     if { [lindex $args 0] == "release" } {
                    259: 	set window [lindex $args 1]
                    260: 	grab release $window
                    261: 	bind all <ButtonRelease> {}
                    262:     } else {
                    263: 	set window [lindex $args 0]
                    264: 	grab $window	
                    265: 	bind all <ButtonRelease> "capaAutoRaise $window %W"
                    266:     }
                    267: }
                    268: 
                    269: proc capaAutoRaise { window reportWin } {
                    270:     if { $window == $reportWin } {
                    271: 	capaRaise $window
                    272: 	focus $window
                    273:     }
                    274: }
                    275: 
                    276: ###########################################################
                    277: # displayMessage
                    278: ###########################################################
                    279: # displays a modal dialog with a message to the user
                    280: ###########################################################
                    281: # Arguments: the message to be displayed
                    282: # Returns: Nothing
                    283: # Globals: gPromptDM - used to detect when the user presses ok
                    284: ###########################################################
                    285: proc displayMessage { msg {color black} } {
                    286:     global gPromptDM
                    287: 
                    288:     set dialog [toplevel .prompt -borderwidth 10]
                    289:     wm geo $dialog "+200+200"
                    290:     wm title $dialog "Message"
                    291: 
                    292:     message $dialog.msg -text "$msg" -aspect 700 -foreground $color
                    293:     set buttonFrame [frame $dialog.buttons -bd 10]
                    294:     pack $dialog.msg $buttonFrame -side top -fill x
                    295:     
                    296:     button $buttonFrame.ok -text Dismiss -command { set gPromptDM(ok) 1 } \
                    297: 	    -underline 0
                    298:     pack $buttonFrame.ok -side left
                    299:     
                    300:     bind $buttonFrame.ok <Return> "set gPromptDM(ok) 1"
                    301:     Centre_Dialog $dialog default
                    302:     update
                    303: 
                    304:     focus $dialog
                    305:     capaRaise $dialog
                    306:     capaGrab $dialog
                    307:     vwait gPromptDM(ok)
                    308:     capaGrab release $dialog
                    309:     destroy $dialog
                    310:     return
                    311: }
                    312: 
                    313: ###########################################################
                    314: # getLprCommand
                    315: ###########################################################
                    316: # builds a command string to print with
                    317: ###########################################################
                    318: # Arguments: name of the file to be printed
                    319: #            num - index of options in gCapaConfig
                    320: # Returns: the print command if accepted, Cancel if cancel was hit 
                    321: # Globals: gPrompt - the variable watched to control when to 
                    322: #                    remove the dialog
                    323: #          gLprCommand - the variable which stores a specified command
                    324: #          gCapaConfig - the variable holding the print strings from
                    325: #                        the capa.config file
                    326: ###########################################################
                    327: proc getLprCommand { PS_file {num ""}} {
                    328:     global gLprCommand gPrompt gCapaConfig Printer_selected
                    329: 
                    330:     if { $num != "" } {	set prefix "$num." } else { set prefix "" }
                    331:     set showPrinterList false
                    332:     set dialog [toplevel .lprCommand -borderwidth 10]
                    333:     wm title $dialog "Command to Print"
                    334:     wm geo $dialog "+200+200"
                    335:     
                    336:     set infoFrame [ frame $dialog.infoFrame ]
                    337:     set optionsFrame [ frame $dialog.optionsFrame ]
                    338:     set buttonFrame [frame $dialog.buttons -bd 10]
                    339:     pack $infoFrame $optionsFrame $buttonFrame -side top -fill x -anchor w 
                    340: 
                    341:     message $infoFrame.msg -text "Select a printing method:" -aspect 5000
                    342:     pack $infoFrame.msg
                    343: 
                    344:     set printInfo [frame $optionsFrame.info]
                    345:     set printerList [frame $optionsFrame.list]
                    346:     set printerListFrame [frame $optionsFrame.printFrame]
                    347:     set oneSidedFrame [frame $optionsFrame.oneSided]
                    348:     set twoSidedFrame [frame $optionsFrame.twoSided]
                    349:     set spaceFrame [frame $optionsFrame.space -height 30]
                    350:     set specifiedFrame [frame $optionsFrame.specified]
                    351:     pack $printInfo $printerList $oneSidedFrame $twoSidedFrame \
                    352: 	    $spaceFrame $specifiedFrame -side top -anchor w
                    353:     pack configure $printInfo -anchor w
                    354:     pack configure $printerList -anchor e
                    355: 
                    356:     if { [array names gLprCommand which] == "" } { set gLprCommand(which) "" }
                    357:     radiobutton $oneSidedFrame.radio -text "One Sided" -value \
                    358: 	    "OneSided" -variable gLprCommand(which)
                    359:     message $oneSidedFrame.cmd -text $gCapaConfig([set prefix]lprOneSided_command) \
                    360: 	    -relief raised -width 600 -aspect 5000
                    361:     if { $gCapaConfig([set prefix]lprOneSided_command) != "" } {
                    362: 	if { $gLprCommand(which) == "" } { set gLprCommand(which) OneSided }
                    363: 	set showPrinterList true
                    364: 	pack $oneSidedFrame.radio $oneSidedFrame.cmd -side top
                    365: 	pack configure $oneSidedFrame.radio -anchor w
                    366: 	pack configure $oneSidedFrame.cmd -anchor e
                    367:     }
                    368: 
                    369:     radiobutton $twoSidedFrame.radio -text "Two Sided" -value \
                    370: 	    "TwoSided" -variable gLprCommand(which)
                    371:     message $twoSidedFrame.cmd -text $gCapaConfig([set prefix]lprTwoSided_command) \
                    372: 	    -relief raised -width 400 -aspect 5000
                    373:     if { $gCapaConfig([set prefix]lprTwoSided_command) != "" } {
                    374: 	if { $gLprCommand(which) == "" } { set gLprCommand(which) TwoSided }
                    375: 	set showPrinterList true
                    376: 	pack $twoSidedFrame.radio $twoSidedFrame.cmd -side top
                    377: 	pack configure $twoSidedFrame.radio -anchor w
                    378: 	pack configure $twoSidedFrame.cmd -anchor e
                    379:     }
                    380:     
                    381:     message $printInfo.text -text "\$Printer_selected = " -aspect 5000
                    382:     message $printInfo.current -textvariable Printer_selected \
                    383: 	    -aspect 5000 
                    384:     pack $printInfo.text $printInfo.current -side left
                    385: 
                    386:     set printerListbox [ listbox $printerList.list -width 20 \
                    387:                -yscrollcommand "$printerList.scroll set" -height 3 ]
                    388:     scrollbar $printerList.scroll -orient v -command "$printerList.list yview" 
                    389:     if { $showPrinterList && $gCapaConfig([set prefix]printer_option) != "" } {
                    390: 	pack $printerListbox $printerList.scroll -side left -anchor e
                    391: 	pack configure $printerList.scroll -fill y
                    392: 	foreach printer $gCapaConfig([set prefix]printer_option) {
                    393: 	    $printerListbox insert end $printer
                    394: 	}
                    395: 	set Printer_selected [lindex $gCapaConfig([set prefix]printer_option) 0]
                    396: 	if { $gCapaConfig(Printer_selected) == "" } {
                    397: 	    set gCapaConfig(Printer_selected) 0
                    398: 	}
                    399: 	$printerListbox selection set $gCapaConfig(Printer_selected)
                    400: 	$printerListbox see $gCapaConfig(Printer_selected)
                    401: 	set script "set Printer_selected \[$printerListbox get \[$printerListbox curselection \] \]"
                    402: 	eval $script
                    403: 	bind $printerListbox <B1-ButtonRelease> "eval $script"
                    404: 	bind $printerListbox <Key> "eval $script"
                    405: 	bind $printerListbox <Motion> "eval $script"
                    406:     }
                    407: 
                    408:     radiobutton $specifiedFrame.radio -text "Specified"  -value \
                    409: 	    "Specified" -variable gLprCommand(which)
                    410:     if { $gLprCommand(which) == "" } { set gLprCommand(which) Specified }
                    411:     message $specifiedFrame.msg -text "Print command:" -aspect 5000
                    412:     entry $specifiedFrame.entry -textvariable gLprCommand(Specified) \
                    413: 	    -width 40 -xscrollcommand "$specifiedFrame.scroll set"
                    414:     trace variable gLprCommand(Specified) w \
                    415: 	"global gLprCommand; set gLprCommand(which) Specified ;#"
                    416:     scrollbar $specifiedFrame.scroll -command "$specifiedFrame.entry xview" \
                    417: 	    -orient h
                    418:     message $specifiedFrame.msg2 -text "Example: lpr -PlocalPrinter" \
                    419: 	    -aspect 5000
                    420:     pack $specifiedFrame.radio $specifiedFrame.msg $specifiedFrame.entry \
                    421: 	    $specifiedFrame.scroll $specifiedFrame.msg2 -side top
                    422:     pack configure $specifiedFrame.radio -anchor w
                    423:     pack configure $specifiedFrame.entry -anchor w
                    424:     pack configure $specifiedFrame.scroll -fill x
                    425: 
                    426:     button $buttonFrame.ok -text Print -command {set gPrompt(yes) 1} \
                    427: 	    -underline 0
                    428:     button $buttonFrame.cancel -text Cancel -command { set gPrompt(yes) 0 } \
                    429: 	    -underline 0
                    430:     pack $buttonFrame.ok $buttonFrame.cancel -side left
                    431: 	
                    432:     bind $dialog <Alt-Key> break
                    433:     
                    434:     Centre_Dialog $dialog default
                    435:     update
                    436: 
                    437:     focus $dialog
                    438:     capaRaise $dialog
                    439:     capaGrab $dialog
                    440:     vwait gPrompt(yes)
                    441:     capaGrab release $dialog
                    442:     if {$gPrompt(yes)} {
                    443: 	switch $gLprCommand(which) {
                    444: 	    Specified { set command "$gLprCommand(Specified)" }
                    445: 	    OneSided  {	set command "$gCapaConfig([set prefix]lprOneSided_command)" }
                    446: 	    TwoSided  {	set command "$gCapaConfig([set prefix]lprTwoSided_command)" }
                    447: 	    default   {
                    448: 		destroy $dialog
                    449: 		return "Cancel" 
                    450: 	    }
                    451: 	}
                    452: 	if { $command == "" } {
                    453: 	    destroy $dialog
                    454: 	    displayError "An empty print command can not be used."
                    455: 	    return "Cancel"
                    456: 	}
                    457: 	set gCapaConfig(Printer_selected) [$printerListbox curselection]
                    458: 	if { [string first \$PS_file $command] == -1 } {
                    459: 	    set command "$command $PS_file"
                    460: 	    set command [subst $command]
                    461: 	} else {
                    462: 	    set command [subst $command]
                    463: 	}
                    464: 	destroy $dialog
                    465: 	return "$command"
                    466:     } else {
                    467: 	destroy $dialog
                    468: 	return "Cancel"
                    469:     }
                    470: }
                    471: 
                    472: ###########################################################
                    473: # makeSure
                    474: ###########################################################
                    475: # generalized Yes No question proc,
                    476: ###########################################################
                    477: # Arguments: a string containing the question to ask the user
                    478: # Returns: Yes, or Cancel
                    479: # Globals: gPrompt - used to watch for a response
                    480: ###########################################################
                    481: proc makeSure { question } {
                    482:     global gPrompt
                    483:     
                    484:     set dialog [toplevel .makeSurePrompt -borderwidth 10]
                    485: 
                    486:     wm geo $dialog "+200+200"
                    487:     message $dialog.msg -text "$question" -aspect 700
                    488:     
                    489:     set gPrompt(result) ""
                    490:     set buttonFrame [frame $dialog.buttons -bd 10]
                    491:     pack $dialog.msg $buttonFrame -side top -fill x
                    492:     
                    493:     button $buttonFrame.yes -text Yes -command {set gPrompt(yes) 1} \
                    494: 	    -underline 0
                    495:     frame  $buttonFrame.spacer 
                    496:     button $buttonFrame.cancel -text No -command { set gPrompt(yes) 0 } \
                    497: 	    -underline 0
                    498:     pack $buttonFrame.yes $buttonFrame.spacer $buttonFrame.cancel -side left
                    499:     pack configure $buttonFrame.spacer -expand 1 -fill x
                    500: 
                    501:     bind $dialog <Alt-Key> break
                    502:     
                    503:     Centre_Dialog $dialog default
                    504:     update
                    505:     
                    506:     focus $dialog
                    507:     capaRaise $dialog
                    508:     capaGrab $dialog
                    509:     vwait gPrompt(yes)
                    510:     capaGrab release $dialog
                    511:     destroy $dialog
                    512:     if {$gPrompt(yes)} {
                    513: 	return Yes
                    514:     } else {
                    515: 	return Cancel
                    516:     }
                    517: }    
                    518: 
                    519: ###########################################################
                    520: # parseCapaConfig
                    521: ###########################################################
                    522: ###########################################################
                    523: ###########################################################
                    524: proc parseCapaConfig { {num "" } { path "" } } {
                    525:     global gCapaConfig
                    526: 
                    527:     if { $num != "" } {
                    528: 	set prefix "$num."
                    529:     } else {
                    530: 	set prefix "" 
                    531:     }
                    532:     if { $path == "" } { set path [pwd] }
                    533:     set filename [file join $path capa.config]
                    534:     set error [ catch { set fileId [open $filename "r"] } ]
                    535:     if { $error } {
                    536: 	displayError "Unable to find a capa.config file in $path."
                    537: 	error "No capa.config"
                    538:     }
                    539:     
                    540:     set saveto ""
                    541:     set saveline false
                    542: 
                    543:     while { 1 } {
                    544: 	gets $fileId aline
                    545: 	if { [eof $fileId ] } { break }
                    546: 	set error [ catch {
                    547: 	    switch -glob -- "$aline" {
                    548: 		"printer_option *= *" {
                    549: 		    lappend gCapaConfig($prefix[lindex $aline 0]) [lindex $aline end]
                    550: 		}
                    551: 		"BeginStandardQuizzerHeader*" {
                    552: 		    set saveto [set prefix]standardQuizzerHeader
                    553: 		    set saveline true
                    554: 		    set gCapaConfig($saveto) ""
                    555: 		    set aline ""
                    556: 		}
                    557: 		"EndStandardQuizzerHeader*" {
                    558: 		    set saveto ""
                    559: 		    set saveline false
                    560: 		}
                    561: 		"quizzerBackupQZ *= *" -
                    562: 		"quizzerBackupRef *= *" -
                    563: 		"lprOneSided_command *= *" -
                    564: 		"lprTwoSided_command *= *" -
                    565: 		"latex_command *= *" -
                    566: 		"allcapaid_command *= *" -
                    567: 		"qzparse_command *= *" -
                    568: 		"answers_command *= *" -
                    569: 		"dvips_command *= *" -
                    570:                 "xdvi_command *= *" -
1.8       albertel  571: 		"mail_command *= *" -
1.1       albertel  572: 		"IMP_color *= *" -
                    573: 		"comment_color *= *" -
                    574: 		"exam_path *= *" -
                    575: 		"quiz_path *= *" -
                    576: 		"supp_path *= *" -
1.8       albertel  577: 		"correction_path *= *" -
1.2       albertel  578: 		"default_try_val *= *" -
                    579: 		"default_prob_val *= *" -
                    580: 		"default_hint_val *= *" -
1.8       albertel  581: 		"homework_weight *= *" -
                    582: 		"quiz_weight *= *" -
                    583: 		"exam_weight *= *" -
                    584: 		"final_weight *= *" -
                    585: 		"correction_weight *= *" -
                    586: 		"final_exam_set_number *= *" -
                    587: 		"homework_count *= *" -
                    588: 		"quiz_count *= *" -
1.1       albertel  589: 		"others_path *= *" { 
                    590: 		    set gCapaConfig($prefix[lindex $aline 0]) [lindex $aline end] 
                    591: 		}
                    592: 	    }
                    593: 	}
                    594:         ]
                    595: 	if { $error } {
                    596: 	    displayError "Error in capa.config file in line: $aline"
                    597: 	}
                    598: 	if { $saveline } {
                    599: 	    append gCapaConfig($saveto) "$aline\n"
                    600: 	}
                    601:     }
                    602:     close $fileId
                    603:     return OK
                    604: }
                    605: 
                    606: ###########################################################
                    607: # parseCapaUtilsConfig
                    608: ###########################################################
                    609: ###########################################################
                    610: ###########################################################
                    611: proc parseCapaUtilsConfig { num path } {
                    612:     global gCapaConfig
                    613:     
                    614:     set filename [file join $path capa.config]
                    615:     set error [ catch { set fileId [open $filename "r"] } ]
                    616:     if { $error } {
                    617: 	displayError "Unable to find a capautils.config file in $path."
                    618: 	error "No capautils.config"
                    619:     }
                    620:     
                    621:     set saveto ""
                    622:     set saveline false
                    623: 
                    624:     while { 1 } {
                    625: 	gets $fileId aline
                    626: 	if { [eof $fileId ] } { break }
                    627: 	set error [ catch {
                    628: 	    switch -glob -- "$aline" {
                    629: 		"homework_scores_limit_set *= *" -
                    630: 		"exam_scores_limit_set *= *" -
                    631: 		"quiz_scores_limit_set *= *" -
                    632: 		"supp_scores_limit_set *= *" -
                    633: 		"others_scores_limit_set *= *" -
                    634: 		"master_scores_file *= *" -
                    635: 		"email_template_file *= *" -
                    636: 		"correction_factor *= *" -
                    637: 		"hw_percent *= *" -
                    638: 		"qz_percent *= *" - 
                    639: 		"mt1_percent *= *" - 
                    640: 		"mt2_percent *= *" - 
                    641: 		"mt3_percent *= *" - 
                    642: 		"final_percent *= *" - 
                    643: 		"category_one_high *= *" -
                    644: 		"category_one_low *= *" -
                    645: 		"category_two_high *= *" -
                    646: 		"category_two_low *= *" -
                    647: 		"category_three_high *= *" -
                    648: 		"category_three_low *= *" -
                    649: 		"category_four_high *= *" -
                    650: 		"category_four_low *= *" -
                    651: 		"display_score_row_limit *= *" 
                    652: 		{
                    653: 		    set gCapaConfig($num.[lindex $aline 0]) [lindex $aline end] 
                    654: 		}
                    655: 	    }
                    656: 	}
                    657: 	]
                    658: 	if { $error } {
                    659: 	    displayError "Error in capautils.config file in line: $aline"
                    660: 	}
                    661: 	if { $saveline } {
                    662: 	    append capaConfig($saveto) "$aline\n"
                    663: 	}
                    664:     }
                    665:     return OK
                    666: }
                    667: 
                    668: ###########################################################
                    669: # removeWindowEntry
                    670: ###########################################################
                    671: # used to deregister a Window Menu entry
                    672: ###########################################################
                    673: # Arguments: the label the window was registered under
                    674: # Returns: nothing
                    675: # Globals: gWindowMenu - name of the WindowMenu
                    676: ###########################################################
                    677: proc removeWindowEntry { label } {
                    678:     global gWindowMenu
                    679: 
                    680:     catch {$gWindowMenu delete $label}
                    681: }
                    682: 
                    683: proc scrolltwo { firstcommand secondcommand args } {
                    684:     eval "$firstcommand $args"
                    685:     eval "$secondcommand $args"
                    686: }
                    687: 
                    688: ###########################################################
                    689: # getTextTagged
                    690: ###########################################################
                    691: ###########################################################
                    692: ###########################################################
                    693: proc getTextTagged { window tag } {
                    694:     if { $tag == "" } { return [$window get 0.0 end-1c] }
                    695:     set result ""
                    696:     set range [$window tag nextrange $tag 0.0]
                    697:     while { $range != "" } {
                    698: 	set index [lindex $range 1]
                    699: 	append result [eval "$window get $range"]
                    700: 	append result "\n"
                    701: 	set range [$window tag nextrange $tag $index]
                    702:     }
                    703:     return $result
                    704: }
                    705: 
                    706: ###########################################################
                    707: # getWhichTags
                    708: ###########################################################
                    709: ###########################################################
                    710: ###########################################################
                    711: proc getWhichTags { descriptions tags action } {
                    712:     set whichtag [eval "tk_dialog .whichtag {Select which messages} \
                    713:                    {Select which set of messages will be $action.} \
                    714:                    {} 0 $descriptions"]
                    715:     return [lindex $tags $whichtag]
                    716: }
                    717: 
                    718: ###########################################################
                    719: # displayStatus
                    720: ###########################################################
                    721: # creates a window on the screen with one or both of a message
                    722: # or a canvas with a status bar, uses updateStatusMessage and
                    723: # updateStatusBar to update the respective parts of the status
                    724: # window, and use removeStatus to remove the status bar from 
                    725: # the screen
                    726: ###########################################################
                    727: # Arguments: the message to be displayed (a blank if one is not wanted)
                    728: #            and one of (both, bar, or message) to specify what
                    729: #            parts one wnats in the status bar and optionally a number
                    730: #            if there might be more than one Status at a time
                    731: # Returns: Nothing
                    732: # Globals: gStatus - an array containing information for the status
                    733: #              ($num.type) - the type of status
                    734: #              ($num.message) - the message in the status window
                    735: #              ($num.bar) - the id number of the rectangle in the canvas
                    736: #              (num) - (Optional) if there are multiple Statuses
                    737: #                      the number of the Status
                    738: ###########################################################
                    739: proc displayStatus { message type {num 0} } {
                    740:     global gStatus
                    741:     if { [winfo exists .status$num]} {
                    742: 	capaRaise .status$num
                    743: 	return 
                    744:     }
                    745:     
                    746:     set status [toplevel .status$num]
                    747: 
                    748:     set gStatus($num.type) $type
                    749:     set gStatus($num.message) "$message"
                    750: 
                    751:     switch $type {
                    752: 	spinner {
                    753: 	    message $status.msg -textvariable gStatus($num.message) -aspect 700
                    754: 	    set gStatus($num.spinner) "-"
                    755: 	    message $status.spinner -textvariable gStatus($num.spinner) -aspect 700
                    756: 	    pack $status.msg $status.spinner -side top
                    757: 	}
                    758: 	both -
                    759: 	bar {
                    760: 	    message $status.msg -textvariable gStatus($num.message) -aspect 700
                    761: 	    canvas $status.canvas -width 200 -height 20
                    762: 	    $status.canvas create rectangle 1 1 199 19 -outline black
                    763: 	    set gStatus($num.bar) [$status.canvas create rectangle 1 1 1 19 \
                    764: 		    -fill red -outline black]
                    765: 	    pack $status.msg $status.canvas -side top
                    766: 	}
                    767: 	message	{
                    768: 	    message $status.msg -textvariable gStatus($num.message) -aspect 700
                    769: 	    pack $status.msg
                    770: 	}
                    771:     }
                    772:     Centre_Dialog $status default
                    773:     update idletasks
                    774: }
                    775: 
                    776: ###########################################################
                    777: # updateStatusMessage 
                    778: ###########################################################
                    779: # updates the message in the status bar
                    780: ###########################################################
                    781: # Arguments: the new message for the status bar and optionally a number
                    782: #            if there might be more than one Status at a time
                    783: # Returns: Nothing
                    784: # Globals: gStatus - an array containing information for the status
                    785: #              ($num.type) - the type of status
                    786: #              ($num.message) - the message in the status window
                    787: #              ($num.bar) - the id number of the rectangle in the canvas
                    788: #              (num) - (Optional) if there are multiple Statuses
                    789: #                      the number of the Status
                    790: ###########################################################
                    791: proc updateStatusMessage { message { num 0 } } {
                    792:     global gStatus
                    793:     set gStatus($num.message) "$message"
                    794:     update idletasks
                    795: }
                    796: 
                    797: ###########################################################
                    798: # updateStatusBar
                    799: ###########################################################
                    800: # updates the bar in the status bar
                    801: ###########################################################
                    802: # Arguments: a floating point number between 0 and 1 that is
                    803: #            the percentage done and optionally a number
                    804: #            if there might be more than one Status at a time
                    805: # Returns: Nothing
                    806: # Globals: gStatus - an array containing information for the status
                    807: #              ($num.type) - the type of status
                    808: #              ($num.message) - the message in the status window
                    809: #              ($num.bar) - the id number of the rectangle in the canvas
                    810: #              (num) - (Optional) if there are multiple Statuses
                    811: #                      the number of the Status
                    812: ###########################################################
                    813: proc updateStatusBar { percent { num 0 } } {
                    814:     global gStatus
                    815:     .status$num.canvas coords $gStatus($num.bar) 1 1 [expr $percent * 200 ] 19
                    816:     update idletasks
                    817: }
                    818: 
                    819: ###########################################################
                    820: # updateStatusSpinner
                    821: ###########################################################
                    822: # updates the spinner in the status bar
                    823: ###########################################################
                    824: # Arguments: optionally a number if there might be more 
                    825: #            than one Status at a time
                    826: # Returns: Nothing
                    827: # Globals: gStatus - an array containing information for the status
                    828: #              ($num.type) - the type of status
                    829: #              ($num.message) - the message in the status window
                    830: #              ($num.bar) - the id number of the rectangle in the canvas
                    831: #              (num) - (Optional) if there are multiple Statuses
                    832: #                      the number of the Status
                    833: ###########################################################
                    834: proc updateStatusSpinner { { num 0 } } {
                    835:     global gStatus
                    836:     switch -- $gStatus($num.spinner) {
                    837: 	"-" { set gStatus($num.spinner) "\\" }
                    838: 	"\\" { set gStatus($num.spinner) "|" }
                    839: 	"|" { set gStatus($num.spinner) "/" }
                    840: 	"/" { set gStatus($num.spinner) "-" }
                    841:     }
                    842:     update idletasks
                    843: }
                    844: 
                    845: ###########################################################
                    846: # removeStatus
                    847: ###########################################################
                    848: # takes the status message off of the screen, must be eventually
                    849: # called after a call to displayStatus
                    850: ###########################################################
                    851: # Arguments: and optionally a number if there might be more 
                    852: #            than one Status at a time
                    853: # Returns: Nothing
                    854: # Globals: gStatus - an array containing information for the status
                    855: #              ($num.type) - the type of status
                    856: #              ($num.message) - the message in the status window
                    857: #              ($num.bar) - the id number of the rectangle in the canvas
                    858: ###########################################################
                    859: proc removeStatus { {num 0 } } {
                    860:     global gStatus
                    861:     foreach name [array names gStatus "$num.*"] { unset gStatus($name) }
                    862:     destroy .status$num
                    863:     update idletasks
                    864: }
                    865: 
                    866: ###########################################################
                    867: # tkFDialogResolveFile 
                    868: ###########################################################
                    869: # I don't like how this version of the Tcl dialog box code
                    870: # evaluates links, my code here makes it so that clicking 
                    871: # on Open does the same thing as double clicking does, it 
                    872: # returns the path in the top of the dialog box along with
                    873: # the new filename
                    874: ###########################################################
                    875: # I do this catch command to get Tcl to source the 
                    876: # tkfbox.tcl file, then I change the tkFDialogResolveFile
                    877: # command
                    878: ###########################################################
                    879: catch {tkFDialogResolveFile}
                    880: proc tkFDialogResolveFile {context text defaultext} {
                    881:     set appPWD [pwd]
                    882: 
                    883:     set path [tkFDialog_JoinFile $context $text]
                    884: 
                    885:     if {[file ext $path] == ""} {
                    886: 	set path "$path$defaultext"
                    887:     }
                    888: 
                    889:     if [catch {file exists $path}] {
                    890: 	return [list ERROR $path ""]
                    891:     }
                    892: 
                    893:     if [catch {if [file exists $path] {}}] {
                    894: 	# This "if" block can be safely removed if the following code returns
                    895: 	# an error. It currently (7/22/97) doesn't
                    896: 	#
                    897: 	#	file exists ~nonsuchuser
                    898: 	#
                    899: 	return [list ERROR $path ""]
                    900:     }
                    901: 
                    902:     if [file exists $path] {
                    903: 	if [file isdirectory $path] {
                    904: 	    if [catch {
                    905: 		cd $path
                    906: 	    }] {
                    907: 		return [list CHDIR $path ""]
                    908: 	    }
                    909: 	    set directory [pwd]
                    910: 	    set file ""
                    911: 	    set flag OK
                    912: 	    cd $appPWD
                    913: 	} else {
                    914: 	    if [catch {
                    915: 		cd [file dirname $path]
                    916: 	    }] {
                    917: 		return [list CHDIR [file dirname $path] ""]
                    918: 	    }
                    919: 	    set directory [pwd]
                    920: 	    set directory [file dirname $path]
                    921: 	    set file [file tail $path]
                    922: 	    set flag OK
                    923: 	    cd $appPWD
                    924: 	}
                    925:     } else {
                    926: 	set dirname [file dirname $path]
                    927: 	if [file exists $dirname] {
                    928: 	    if [catch {
                    929: 		cd $dirname
                    930: 	    }] {
                    931: 		return [list CHDIR $dirname ""]
                    932: 	    }
                    933: 	    set directory [pwd]
                    934: 	    set file [file tail $path]
                    935: 	    if [regexp {[*]|[?]} $file] {
                    936: 		set flag PATTERN
                    937: 	    } else {
                    938: 		set flag FILE
                    939: 	    }
                    940: 	    cd $appPWD
                    941: 	} else {
                    942: 	    set directory $dirname
                    943: 	    set file [file tail $path]
                    944: 	    set flag PATH
                    945: 	}
                    946:     }
                    947: 
                    948:     return [list $flag $directory $file]
                    949: }
                    950: 
                    951: ###########################################################
                    952: # tkIconList_Create
                    953: ###########################################################
                    954: # Ed wants a bigger default dialog box
                    955: ###########################################################
                    956: # I do this catch command to get Tcl to source the 
                    957: # tkfbox.tcl file, then I change the tkIconList_Create
                    958: # command
                    959: ###########################################################
                    960: catch {tkIconList_Create}
                    961: proc tkIconList_Create {w} {
                    962:     upvar #0 $w data
                    963: 
                    964:     frame $w
                    965:     set data(sbar)   [scrollbar $w.sbar -orient horizontal \
                    966:         -highlightthickness 0 -takefocus 0]
                    967:     set data(canvas) [canvas $w.canvas -bd 2 -relief sunken \
                    968:         -width 600 -height 180 -takefocus 1]
                    969:     pack $data(sbar) -side bottom -fill x -padx 2
                    970:     pack $data(canvas) -expand yes -fill both
                    971: 
                    972:     $data(sbar) config -command "$data(canvas) xview"
                    973:     $data(canvas) config -xscrollcommand "$data(sbar) set"
                    974: 
                    975:     # Initializes the max icon/text width and height and other variables
                    976:     #
                    977:     set data(maxIW) 1
                    978:     set data(maxIH) 1
                    979:     set data(maxTW) 1
                    980:     set data(maxTH) 1
                    981:     set data(numItems) 0
                    982:     set data(curItem)  {}
                    983:     set data(noScroll) 1
                    984: 
                    985:     # Creates the event bindings.
                    986:     #
                    987:     bind $data(canvas) <Configure> "tkIconList_Arrange $w"
                    988: 
                    989:     bind $data(canvas) <1>         "tkIconList_Btn1 $w %x %y"
                    990:     bind $data(canvas) <B1-Motion> "tkIconList_Motion1 $w %x %y"
                    991:     bind $data(canvas) <Double-1>  "tkIconList_Double1 $w %x %y"
                    992:     bind $data(canvas) <ButtonRelease-1> "tkCancelRepeat"
                    993:     bind $data(canvas) <B1-Leave>  "tkIconList_Leave1 $w %x %y"
                    994:     bind $data(canvas) <B1-Enter>  "tkCancelRepeat"
                    995: 
                    996:     bind $data(canvas) <Up>        "tkIconList_UpDown $w -1"
                    997:     bind $data(canvas) <Down>      "tkIconList_UpDown $w  1"
                    998:     bind $data(canvas) <Left>      "tkIconList_LeftRight $w -1"
                    999:     bind $data(canvas) <Right>     "tkIconList_LeftRight $w  1"
                   1000:     bind $data(canvas) <Return>    "tkIconList_ReturnKey $w"
                   1001:     bind $data(canvas) <KeyPress>  "tkIconList_KeyPress $w %A"
                   1002:     bind $data(canvas) <Control-KeyPress> ";"
                   1003:     bind $data(canvas) <Alt-KeyPress>  ";"
                   1004: 
                   1005:     bind $data(canvas) <FocusIn>   "tkIconList_FocusIn $w"
                   1006: 
                   1007:     return $w
                   1008: }
                   1009: 
                   1010: ###########################################################
                   1011: # findByStudentNumber
                   1012: ###########################################################
                   1013: ###########################################################
                   1014: ###########################################################
                   1015: proc findByStudentNumber { pattern path } {
                   1016:     set file [file join $path "classl"]
                   1017:     if {[catch {set fileId [open $file "r"]}]} { return "" }
                   1018:     set matched_entries ""
                   1019:     set aline [gets $fileId]
                   1020:     while { ! [eof $fileId] } {
                   1021: 	set aline [string trimright $aline]
                   1022: 	set tmp_sn [string range $aline 14 22]
                   1023: 	if { [regexp -nocase $pattern $tmp_sn] } {
                   1024: 	    lappend matched_entries [ list $tmp_sn [string range $aline 24 53] ]
                   1025: 	}
                   1026: 	set aline [gets $fileId]
                   1027:     }
                   1028:     close $fileId
                   1029:     return $matched_entries
                   1030: }
                   1031: 
                   1032: ###########################################################
                   1033: # findByStudentName
                   1034: ###########################################################
                   1035: ###########################################################
                   1036: ###########################################################
                   1037: proc findByStudentName { pattern path } {
                   1038:     set file [file join $path "classl"]
                   1039:     if {[catch {set fileId [open $file "r"]}]} { return "" }
                   1040:     set matched_entries ""
                   1041:     set aline [gets $fileId]
                   1042:     while { ! [eof $fileId] } {
                   1043: 	set aline [string trimright $aline]
                   1044: 	set tmp_name [string range $aline 24 53]
                   1045: 	if { [regexp -nocase $pattern $tmp_name] } {
                   1046: 	    lappend matched_entries [list [string range $aline 14 22] $tmp_name]
                   1047: 	}
                   1048: 	set aline [gets $fileId]
                   1049:     }
                   1050:     close $fileId
                   1051:     return $matched_entries
                   1052: }
                   1053: 
                   1054: ###########################################################
                   1055: # fillInStudent
                   1056: ###########################################################
                   1057: ###########################################################
                   1058: ###########################################################
                   1059: proc fillInStudent { fullnameVar numberVar doname } {
                   1060:     upvar $fullnameVar fullname $numberVar number
                   1061: 
                   1062:     if { !$doname } {
                   1063: 	set matched_entries [findByStudentNumber [string trim $number] .]
                   1064:     } else {
                   1065: 	set matched_entries [findByStudentName [string trim $fullname] .]
                   1066:     }
                   1067:     if { [llength $matched_entries] == 0 } {
                   1068: 	displayMessage "No student found. Please re-enter student info."
                   1069: 	set id ""; set name ""
                   1070:     } elseif { [llength $matched_entries] == 1 } {
                   1071: 	set id [lindex [lindex $matched_entries 0] 0]
                   1072: 	set name [lindex [lindex $matched_entries 0] 1]
                   1073:     } else {
                   1074: 	set select [ multipleChoice .main "Matched Student Records, Select one" \
                   1075: 			 $matched_entries ]
                   1076: 	if { $select == "" } { 
                   1077: 	    set id ""; set name "" 
                   1078: 	} else {
                   1079: 	    set id [lindex $select 0]
                   1080: 	    set name [lindex $select 1]
                   1081: 	}
                   1082:     }
                   1083:     set fullname $name
                   1084:     set number $id
                   1085: }
                   1086: 
                   1087: ###########################################################
                   1088: # getOneStudent
                   1089: ###########################################################
                   1090: # Lets you pick a student by name or student number
                   1091: # then verifies that they are in the classlist
                   1092: ###########################################################
                   1093: ###########################################################
                   1094: proc getOneStudent { window path idVar nameVar {message "" } {message2 ""}} {
                   1095:     upvar $idVar id
                   1096:     upvar $nameVar name
                   1097:     
                   1098:     set select [tk_dialog $window.dialog "Student select method" \
                   1099: 		    "$message Select student by:" "" "" "Student Number" \
                   1100: 		    "Student Name" "Cancel"]
                   1101:     if { $select == 2 } { 
                   1102: 	set id ""
                   1103: 	set name ""
                   1104: 	return 
                   1105:     }
                   1106:     set done 0
                   1107:     while { ! $done } {
                   1108: 	if { $select } { set search "name" } { set search "number" }
                   1109: 	set pattern [ getString $window "$message Please enter a student $search." ]
                   1110: 	if {$pattern == "" } {
                   1111: 	    set done 1
                   1112: 	    set id ""
                   1113: 	    set name ""
                   1114: 	    continue
                   1115: 	}
                   1116: 	if { $select } {
                   1117: 	    set matched_entries [findByStudentName $pattern $path]
                   1118: 	} else {
                   1119: 	    set matched_entries [findByStudentNumber $pattern $path]
                   1120: 	}
                   1121: 	if { [llength $matched_entries] == 0 } {
                   1122: 	    displayMessage "No student found. Please re-enter student $search."
                   1123: 	} elseif { [llength $matched_entries] == 1 } {
                   1124: 	    set id [lindex [lindex $matched_entries 0] 0]
                   1125: 	    set name [lindex [lindex $matched_entries 0] 1]
                   1126: 	    set done 1
                   1127: 	} elseif { [llength $matched_entries] < 30 } {
                   1128: 	    set select [ multipleChoice $window "Matched Student Records, Select one. $message2" \
                   1129: 			     $matched_entries ]
                   1130: 	    if { $select == "" } { 
                   1131: 		set id ""; set name ""
                   1132: 		return 
                   1133: 	    }
                   1134: 	    set id [lindex $select 0]
                   1135: 	    set name [lindex $select 1]
                   1136: 	    set done 1
                   1137: 	} else {
                   1138: 	    displayMessage "There were [llength $matched_entries], please enter more data to narrow the search."
                   1139: 	}
                   1140:     }
                   1141: }
                   1142: 
                   1143: ###########################################################
                   1144: # getString
                   1145: ###########################################################
                   1146: ###########################################################
                   1147: ###########################################################
1.3       albertel 1148: proc getString { window message {type "any"}} {
1.1       albertel 1149:     global gPrompt 
                   1150:     set setWin [toplevel $window.getstring]
                   1151:     
                   1152:     set msgFrame [frame $setWin.msgFrame]
                   1153:     set valFrame [frame $setWin.valFrame]
                   1154:     set buttonFrame [frame $setWin.buttonFrame]
                   1155:     pack $msgFrame $valFrame $buttonFrame
                   1156: 
                   1157:     
                   1158:     set gPrompt(val) ""
1.3       albertel 1159:     entry $valFrame.val -textvariable gPrompt(val) -validate key \
                   1160: 	-validatecommand "limitEntry %W -1 $type %P"
1.1       albertel 1161:     pack $valFrame.val
                   1162: 
                   1163:     message $msgFrame.msg -text $message -aspect 3000
                   1164:     pack $msgFrame.msg
                   1165: 
                   1166:     button $buttonFrame.select -text "Continue" -command { set gPrompt(ok) 1 }
                   1167:     button $buttonFrame.cancel -text "Cancel" -command { set gPrompt(ok) 0 }
                   1168:     pack $buttonFrame.select $buttonFrame.cancel -side left
                   1169: 
                   1170: 
                   1171:     bind $setWin <Return> "set gPrompt(ok) 1"
                   1172:     Centre_Dialog $setWin default
                   1173:     update idletasks
                   1174:     focus $setWin
                   1175:     focus $valFrame.val
                   1176:     capaRaise $setWin
                   1177:     capaGrab $setWin
                   1178:     vwait gPrompt(ok)
                   1179:     capaGrab release $setWin
                   1180:     destroy $setWin
                   1181:     if { $gPrompt(ok) == 1 } {
                   1182: 	return $gPrompt(val)
                   1183:     } else {
                   1184: 	return ""
                   1185:     }
                   1186: }
                   1187: 
                   1188: ###########################################################
                   1189: # multipleChoice
                   1190: ###########################################################
                   1191: ###########################################################
                   1192: ###########################################################
                   1193: proc multipleChoice { window message choices {single 1}} {
                   1194:     global gPromptMC
                   1195:     
1.2       albertel 1196:     set setWin [toplevel $window.choice]
1.1       albertel 1197:     
                   1198:     set msgFrame [frame $setWin.msgFrame]
                   1199:     set valFrame [frame $setWin.valFrame]
                   1200:     set buttonFrame [frame $setWin.buttonFrame]
                   1201:     pack $msgFrame $valFrame $buttonFrame
                   1202:     pack configure $valFrame -expand 1 -fill both
                   1203: 
                   1204:     message $msgFrame.msg -text $message -aspect 3000
                   1205:     pack $msgFrame.msg
                   1206:     
                   1207:     set maxWidth 1
                   1208:     foreach choice $choices {
                   1209: 	if {[string length $choice] > $maxWidth} {set maxWidth [string length $choice]}
                   1210:     }
                   1211:     set selectMode extended
                   1212:     if { $single } { set selectMode single }
                   1213:     listbox $valFrame.val -width [expr $maxWidth + 2] \
                   1214: 	-yscrollcommand "$valFrame.scroll set" -selectmode $selectMode
                   1215:     scrollbar $valFrame.scroll -command "$valFrame.val yview"
                   1216:     pack $valFrame.val $valFrame.scroll -side left
                   1217:     pack configure $valFrame.val -expand 1 -fill both 
                   1218:     pack configure $valFrame.scroll -expand 0 -fill y
                   1219:     foreach choice $choices { $valFrame.val insert end $choice }
                   1220: 
                   1221:     button $buttonFrame.select -text "Continue" -command { set gPromptMC(ok) 1 }
                   1222:     frame $buttonFrame.spacer -width 10
                   1223:     button $buttonFrame.selectall -text "SelectAll" -command \
                   1224: 	"$valFrame.val selection set 0 end"
                   1225:     button $buttonFrame.cancel -text "Cancel" -command { set gPromptMC(ok) 0 }
                   1226:     if { $single } {
                   1227: 	pack $buttonFrame.select $buttonFrame.cancel -side left
                   1228:     } else {
                   1229: 	pack $buttonFrame.select $buttonFrame.spacer \
                   1230: 	    $buttonFrame.selectall $buttonFrame.cancel -side left
                   1231:     }
                   1232: 
                   1233:     bind $setWin <Return> "set gPromptMC(ok) 1"
1.8       albertel 1234:     bind $setWin <Double-1> "set gPromptMC(ok) 1"
1.1       albertel 1235:     Centre_Dialog $setWin default
                   1236:     update idletasks
                   1237:     focus $setWin
                   1238:     capaRaise $setWin
                   1239:     capaGrab $setWin
                   1240:     while { 1 } {
                   1241: 	update idletasks
                   1242: 	vwait gPromptMC(ok)
                   1243: 	if { $gPromptMC(ok) != 1 } { break }
                   1244: 	set select [$valFrame.val curselection]
                   1245: 	if { $select != "" } { break } 
                   1246:     }
                   1247:     capaGrab release $setWin
                   1248:     destroy $setWin
1.8       albertel 1249:     update idletasks
1.1       albertel 1250:     if { $gPromptMC(ok) == 1 } {
                   1251: 	foreach selection $select { lappend result [lindex $choices $selection] }
                   1252: 	if { [llength $result] == 1 } { set result [lindex $result 0] }
                   1253: 	return $result
                   1254:     } else {
                   1255: 	return ""
                   1256:     }
                   1257: }
                   1258: 
                   1259: ###########################################################
                   1260: # getSetRange
                   1261: ###########################################################
                   1262: ###########################################################
                   1263: ###########################################################
                   1264: proc getSetRange { window path } {
                   1265:     global gMaxSet gPromptGSR
                   1266:     for { set i 1 } { $i <= $gMaxSet } { incr i } {
                   1267: 	if { ! [file exists [file join $path records "set$i.db"]] } { break }
                   1268:     }
                   1269:     incr i -1
                   1270:     
                   1271:     set setWin [toplevel $window.setselect]
                   1272:     
                   1273:     set msgFrame [frame $setWin.msgFrame]
                   1274:     set valFrame [frame $setWin.calFrame]
                   1275:     set buttonFrame [frame $setWin.buttonFrame]
                   1276:     pack $msgFrame $valFrame $buttonFrame
                   1277: 
                   1278:     message $msgFrame.msg -text "Please select a set range:" -aspect 1000
                   1279:     pack $msgFrame.msg
                   1280:     
                   1281:     global gSetNumberStart gSetNumberEnd
                   1282:     scale $valFrame.start -from 1 -to $i -variable gSetNumberStart -orient h
                   1283:     scale $valFrame.end -from 1 -to $i -variable gSetNumberEnd  -orient h
                   1284:     pack $valFrame.start $valFrame.end
                   1285: 
                   1286:     button $buttonFrame.select -text "Select" -command { set gPromptGSR(ok) 1 }
                   1287:     button $buttonFrame.cancel -text "Cancel" -command { set gPromptGSR(ok) 0 }
                   1288:     pack $buttonFrame.select $buttonFrame.cancel -side left
                   1289: 
                   1290:     bind $setWin <Return> "set gPromptGSR(ok) 1"
                   1291:     Centre_Dialog $setWin default
                   1292:     update idletasks
                   1293:     focus $setWin
                   1294:     capaRaise $setWin
                   1295:     capaGrab $setWin
                   1296:     vwait gPromptGSR(ok)
                   1297:     capaGrab release $setWin
                   1298:     destroy $setWin
                   1299:     if { $gPromptGSR(ok) == 1 } {
                   1300: 	set setIdStart $gSetNumberStart
                   1301: 	set setIdEnd $gSetNumberEnd
                   1302: 	if { $setIdStart > $setIdEnd } { set setIdEnd $setIdStart }
                   1303: 	unset gSetNumberStart
                   1304: 	unset gSetNumberEnd
                   1305: 	return [list $setIdStart $setIdEnd]
                   1306:     } else {
                   1307: 	unset gSetNumberStart
                   1308: 	unset gSetNumberEnd
                   1309: 	return ""
                   1310:     }
                   1311: }
                   1312: 
                   1313: ###########################################################
                   1314: # getOneSet
                   1315: ###########################################################
                   1316: ###########################################################
                   1317: ###########################################################
                   1318: proc getOneSet { window path } {
                   1319:     global gMaxSet  gPromptGOS 
                   1320:     for { set i 1 } { $i <= $gMaxSet } { incr i } {
                   1321: 	if { ! [file exists [file join $path records "set$i.db"]] } { break }
                   1322:     }
                   1323:     incr i -1
                   1324:     
                   1325:     set setWin [toplevel $window.setselect]
                   1326:     
                   1327:     set msgFrame [frame $setWin.msgFrame]
                   1328:     set valFrame [frame $setWin.calFrame]
                   1329:     set buttonFrame [frame $setWin.buttonFrame]
                   1330:     pack $msgFrame $valFrame $buttonFrame
                   1331: 
                   1332:     message $msgFrame.msg -text "Please select a set:" -aspect 1000
                   1333:     pack $msgFrame.msg
                   1334:     
                   1335:     global gSetNumber
                   1336:     scale $valFrame.val -from 1 -to $i -variable gSetNumber -orient h
                   1337:     pack $valFrame.val
                   1338: 
                   1339:     button $buttonFrame.select -text "Select" -command { set gPromptGOS(ok) 1 }
                   1340:     button $buttonFrame.cancel -text "Cancel" -command { set gPromptGOS(ok) 0 }
                   1341:     pack $buttonFrame.select $buttonFrame.cancel -side left
                   1342: 
                   1343:     bind $setWin <Return> "set gPromptGOS(ok) 1"
                   1344:     Centre_Dialog $setWin default
                   1345:     update idletasks
                   1346:     focus $setWin
                   1347:     capaRaise $setWin
                   1348:     capaGrab $setWin
                   1349:     vwait gPromptGOS(ok)
                   1350:     capaGrab release $setWin
                   1351:     destroy $setWin
                   1352:     if { $gPromptGOS(ok) == 1 } {
                   1353: 	set setId $gSetNumber
                   1354: 	unset gSetNumber
                   1355: 	return $setId
                   1356:     } else {
                   1357: 	unset gSetNumber
                   1358: 	return ""
                   1359:     }
                   1360: }
                   1361: 
                   1362: ###########################################################
                   1363: # pickSections
                   1364: ###########################################################
                   1365: ###########################################################
                   1366: ###########################################################
                   1367: proc pickSections { sectionsToPickFrom {title "Select Sections"} {window ""}} {
                   1368:     global gPromptPS
                   1369:     
                   1370:     set dialog [toplevel $window.pickSections -borderwidth 10]
                   1371:     wm title $dialog "Which Sections"
                   1372: 
                   1373:     set infoFrame [frame $dialog.info ]
                   1374:     set sectionListFrame [frame $dialog.list  -relief groove -borderwidth 5]
                   1375:     set buttonFrame [frame $dialog.buttons -bd 10]
                   1376:     pack $infoFrame $sectionListFrame $buttonFrame -side top -fill x
                   1377:     
                   1378:     message $infoFrame.msg -text $title -aspect 5000
                   1379:     pack $infoFrame.msg
                   1380: 
                   1381:     set headerFrame [frame $sectionListFrame.head ]
                   1382:     set listboxFrame [frame $sectionListFrame.listboxframe]
                   1383:     pack $headerFrame $listboxFrame -side top 
                   1384:     pack configure $headerFrame -anchor w
                   1385: 
                   1386:     message $headerFrame.msg -text "Section number    # of students" \
                   1387: 	    -aspect 5000
                   1388:     pack $headerFrame.msg
                   1389: 
                   1390:     set sectionList [ listbox $listboxFrame.list \
                   1391:                -yscrollcommand "$listboxFrame.scroll set" \
                   1392:                -width 30 -height 10 -selectmode extended ]
                   1393:     scrollbar $listboxFrame.scroll \
                   1394:                 -command "$listboxFrame.list yview" \
                   1395:                 -orient v
                   1396:     pack $sectionList $listboxFrame.scroll -side left
                   1397:     pack configure $listboxFrame.scroll -fill y      
                   1398: 
                   1399:     foreach section $sectionsToPickFrom {
                   1400: 	$sectionList insert end \
                   1401: 		[format "%3d                  %4d" [lindex $section 0]\
                   1402: 		[lindex $section 1] ]
                   1403:     }
                   1404: 
                   1405:     button $buttonFrame.yes -text Continue -command {set gPromptPS(yes) 1} \
                   1406: 	    -underline 0
                   1407:     frame $buttonFrame.spacer -width 10
                   1408:     button $buttonFrame.selectall -text "SelectAll" -command \
                   1409: 	"$sectionList selection set 0 end"
                   1410:     button $buttonFrame.cancel -text Cancel -command { set gPromptPS(yes) 0 } \
                   1411: 	    -underline 0
                   1412:     bind $dialog <Destroy> "set gPromptPS(yes) 0"
                   1413: 
                   1414:     pack $buttonFrame.yes $buttonFrame.spacer \
                   1415: 	$buttonFrame.selectall $buttonFrame.cancel -side left
                   1416:     
                   1417:     bind $dialog <Alt-Key> break
                   1418:     
                   1419:     Centre_Dialog $dialog default
                   1420:     update
                   1421:     
                   1422:     focus $dialog
                   1423:     capaRaise $dialog
                   1424:     capaGrab $dialog
                   1425:     vwait gPromptPS(yes)
                   1426:     capaGrab release $dialog
                   1427:     bind $dialog <Destroy> ""
                   1428:     if {$gPromptPS(yes)} {
                   1429: 	set selectionList [ $sectionList curselection ]
                   1430: 	set sectionsToPrint ""
                   1431: 	foreach selection $selectionList {
                   1432: 	    append sectionsToPrint "[lindex [$sectionList get $selection] 0] "
                   1433: 	}
                   1434: 	destroy $dialog
                   1435: 	return $sectionsToPrint
                   1436:     } else {
                   1437: 	destroy $dialog
                   1438: 	return Cancel
                   1439:     }
                   1440: }
                   1441: 
                   1442: ###########################################################
1.5       albertel 1443: # pickSets
                   1444: ###########################################################
                   1445: ###########################################################
                   1446: ###########################################################
1.6       albertel 1447: proc pickSets { setsToPickFrom mode {title "Select Sets"} {window ""}} {
1.5       albertel 1448:     global gPromptPSets
                   1449:     
1.6       albertel 1450:     if { $setsToPickFrom == "" } { 
                   1451: 	displayMessage "No available sets."
                   1452: 	return "Cancel" 
                   1453:     }
1.5       albertel 1454:     set dialog [toplevel $window.pickSets -borderwidth 10]
                   1455:     wm title $dialog "Which Sets"
                   1456: 
                   1457:     set infoFrame [frame $dialog.info ]
                   1458:     set setListFrame [frame $dialog.list  -relief groove -borderwidth 5]
                   1459:     set buttonFrame [frame $dialog.buttons -bd 10]
                   1460:     pack $infoFrame $setListFrame $buttonFrame -side top -fill x
                   1461:     
                   1462:     message $infoFrame.msg -text $title -aspect 5000
                   1463:     pack $infoFrame.msg
                   1464: 
                   1465:     set headerFrame [frame $setListFrame.head ]
                   1466:     set listboxFrame [frame $setListFrame.listboxframe]
                   1467:     pack $headerFrame $listboxFrame -side top 
                   1468:     pack configure $headerFrame -anchor w
                   1469: 
                   1470:     message $headerFrame.msg -text "Set #" -aspect 5000
                   1471:     pack $headerFrame.msg
                   1472: 
                   1473:     set setList [ listbox $listboxFrame.list \
                   1474:                -yscrollcommand "$listboxFrame.scroll set" \
                   1475:                -width 30 -height 10 -selectmode $mode ]
                   1476:     scrollbar $listboxFrame.scroll \
                   1477:                 -command "$listboxFrame.list yview" \
                   1478:                 -orient v
                   1479:     pack $setList $listboxFrame.scroll -side left
                   1480:     pack configure $listboxFrame.scroll -fill y      
                   1481: 
                   1482:     foreach set $setsToPickFrom {
1.6       albertel 1483: 	$setList insert end [format "%3d" $set]
1.5       albertel 1484:     }
                   1485: 
                   1486:     button $buttonFrame.yes -text Continue -command {set gPromptPSets(yes) 1} \
                   1487: 	    -underline 0
                   1488:     frame $buttonFrame.spacer -width 10
                   1489:     button $buttonFrame.selectall -text "SelectAll" -command \
                   1490: 	"$setList selection set 0 end"
                   1491:     button $buttonFrame.cancel -text Cancel -command { set gPromptPSets(yes) 0 } \
                   1492: 	    -underline 0
                   1493:     bind $dialog <Destroy> "set gPromptPSets(yes) 0"
1.6       albertel 1494:     bind $dialog <Double-1> "set gPromptPSets(yes) 1"
1.5       albertel 1495: 
1.6       albertel 1496:     if { $mode == "single" } {
                   1497: 	pack $buttonFrame.yes $buttonFrame.cancel -side left
                   1498:     } else {
                   1499: 	pack $buttonFrame.yes $buttonFrame.spacer \
                   1500: 	    $buttonFrame.selectall $buttonFrame.cancel -side left
                   1501:     }
1.5       albertel 1502:     
                   1503:     bind $dialog <Alt-Key> break
                   1504:     
                   1505:     Centre_Dialog $dialog default
                   1506:     update
                   1507:     
                   1508:     focus $dialog
                   1509:     capaRaise $dialog
                   1510:     capaGrab $dialog
                   1511:     vwait gPromptPSets(yes)
                   1512:     capaGrab release $dialog
                   1513:     bind $dialog <Destroy> ""
                   1514:     if {$gPromptPSets(yes)} {
                   1515: 	set selectionList [ $setList curselection ]
                   1516: 	set setsToDo ""
                   1517: 	foreach selection $selectionList {
1.6       albertel 1518: 	    lappend setsToDo [string trim [lindex [$setList get $selection] 0]]
1.5       albertel 1519: 	}
                   1520: 	destroy $dialog
                   1521: 	return $setsToDo
                   1522:     } else {
                   1523: 	destroy $dialog
                   1524: 	return Cancel
                   1525:     }
                   1526: }
                   1527: 
                   1528: ###########################################################
1.1       albertel 1529: # getSet
                   1530: ###########################################################
                   1531: ###########################################################
                   1532: ###########################################################
                   1533: proc getSet { pid set followupCommand {start 1}} {
                   1534:     global gCapaConfig gGetSet gUniqueNumber
                   1535:     set num [incr gUniqueNumber]
                   1536:     if { $start } { 
                   1537: 	set gGetSet($num.toprocess) $pid
                   1538: 	set gGetSet($num.command) $followupCommand
                   1539: 	if { [array names gGetSet exit] == "" } { set gGetSet(exit) 0 }
                   1540:     }
                   1541:     if { [catch {set gCapaConfig(getSet.answers_command)}] } {parseCapaConfig getSet}
1.4       albertel 1542:     set command "$gCapaConfig(getSet.answers_command) $pid {} 1 $set"
1.1       albertel 1543:     foreach var [array names gCapaConfig $num.*] { unset gCapaConfig($var) }
                   1544:     set fileId [open "|$command" "r"]
1.9     ! albertel 1545: #    puts "new command $num $fileId"
1.1       albertel 1546:     fileevent $fileId readable "getSetLine $num $fileId"
                   1547:     update idletasks
                   1548: }
                   1549: 
                   1550: ###########################################################
                   1551: # getSetQuestion
                   1552: ###########################################################
                   1553: ###########################################################
                   1554: ###########################################################
                   1555: proc getSetQuestion { num fileId } {
                   1556:     global gGetSet 
1.9     ! albertel 1557: #    puts -nonewline "$num $fileId "
1.1       albertel 1558:     if { $gGetSet(exit) } { 
                   1559: 	fileevent $fileId readable ""
                   1560: 	catch {close $fileId}
                   1561: 	return
                   1562:     }
                   1563:     set questNum $gGetSet($num.questNum)
                   1564:     set aline [gets $fileId]
                   1565:     if { $aline != "" } {
                   1566: 	switch [lindex [split $aline :] 0] {
1.9     ! albertel 1567: 	    EQES { 
        !          1568: #		puts -nonewline " EQES "
        !          1569: 		fileevent $fileId readable "getSetLine $num $fileId" 
        !          1570: 	    }
        !          1571: 	    default { 
        !          1572: #		puts -nonewline " QES TEXT " 
        !          1573: 		lappend gGetSet($num.$questNum.quest) $aline 
        !          1574: 	    }
1.1       albertel 1575: 	}
1.9     ! albertel 1576:     } else {
        !          1577: #	puts -nonewline " QES BLANK "
1.1       albertel 1578:     }
                   1579:     if { [eof $fileId] } { getSetEnd $fileId }
1.9     ! albertel 1580: #    puts ""
1.1       albertel 1581: }
                   1582: 
                   1583: ###########################################################
                   1584: # getSetLine
                   1585: ###########################################################
                   1586: ###########################################################
                   1587: ###########################################################
                   1588: proc getSetLine { num fileId } {
                   1589:     global gGetSet 
                   1590:     
1.9     ! albertel 1591: #    puts -nonewline "$num $fileId "
1.1       albertel 1592:     if { $gGetSet(exit) } { 
                   1593: 	fileevent $fileId readable ""
                   1594: 	catch {close $fileId}
                   1595: 	return
                   1596:     }
                   1597:     set aline [gets $fileId]
                   1598:     if { $aline != "" } {
                   1599: 	switch [lindex [split $aline :] 0] {
                   1600: 	    ANS { 
1.9     ! albertel 1601: 		set list [array name gGetSet "$num.*"]
        !          1602: #		puts -nonewline " ANS $aline :$list: "
1.1       albertel 1603: 		set questNum $gGetSet($num.questNum)
                   1604: 		set ans [string range $aline 4 end]
                   1605: 		set length [llength $ans]
                   1606: 		lappend gGetSet($num.$questNum.ans) [lindex $ans 0]
                   1607: 		if { ($length == 2) || ($length == 4)} {
                   1608: 		    lappend gGetSet($num.$questNum.unit) [lindex $ans end]
                   1609: 		} 
                   1610: 		if { ($length == 3) || ($length == 4) } {
                   1611: 		    lappend gGetSet($num.$questNum.low) [lindex $ans 1]
                   1612: 		    lappend gGetSet($num.$questNum.high) [lindex $ans 2]
                   1613: 		}
1.9     ! albertel 1614: 		set list [array name gGetSet "$num.*"]
        !          1615: #		puts -nonewline " $ans :$list: "
1.1       albertel 1616: 	    }
1.9     ! albertel 1617: 	    DONE {
        !          1618: # 		puts -nonewline " DONE "
        !          1619: 		set gGetSet($num.maxprob) $gGetSet($num.questNum) }
1.1       albertel 1620: 	    ERROR {
1.9     ! albertel 1621: #		puts -nonewline " ERROR "
1.1       albertel 1622:  		fileevent $fileId readable ""
                   1623: 		displayError "Answers returned invalid message: $aline" 
                   1624: 		fileevent $fileId readable "getSetLine $num $fileId"
                   1625: 	    }
                   1626: 	    BQES {
1.9     ! albertel 1627: #		puts -nonewline " BQES "
1.1       albertel 1628:  		incr gGetSet($num.questNum)
                   1629: 		fileevent $fileId readable "getSetQuestion $num $fileId" 
                   1630: 	    }
1.9     ! albertel 1631: 	    SET { 
        !          1632: #		puts -nonewline " SET "
        !          1633: 		set gGetSet($num.questNum) 0 
        !          1634: 	    }
        !          1635: 	    default { # puts "What's this: $aline" }
1.1       albertel 1636: 	}
1.9     ! albertel 1637:     } else {
        !          1638: #	puts -nonewline "BLANK"
1.1       albertel 1639:     }
                   1640:     if { [eof $fileId] } { getSetEnd $num $fileId }
1.9     ! albertel 1641: #    puts ""
1.1       albertel 1642: }
                   1643: 
                   1644: ###########################################################
                   1645: # getSetEnd
                   1646: ###########################################################
                   1647: ###########################################################
                   1648: ###########################################################
                   1649: proc getSetEnd { num fileId } {
1.9     ! albertel 1650:     global gGetSet
1.1       albertel 1651:     if { [eof $fileId] } {
                   1652: 	catch {close $fileId} 
                   1653: 	set command $gGetSet($num.command)
1.9     ! albertel 1654: #	puts [array name gGetSet "$num.*"]
        !          1655: #	parray gGetSet
1.1       albertel 1656: 	foreach var [array names gGetSet "$num.*"] { 
                   1657: 	    set var2 [join [lrange [split $var .] 1 end] .]
                   1658: 	    set array($var2) $gGetSet($var) 
1.9     ! albertel 1659: #	    puts "unset $var"
1.1       albertel 1660: 	    unset gGetSet($var)
                   1661: 	}
1.9     ! albertel 1662: #	parray gGetSet
        !          1663: 	eval $command [list [array get array]]
1.1       albertel 1664:     }
                   1665: }
                   1666: 
                   1667: ###########################################################
                   1668: # lunique --
                   1669: #   order independent list unique proc.  most efficient, but requires
                   1670: #   __LIST never be an element of the input list
                   1671: # Arguments:
                   1672: #   __LIST      list of items to make unique
                   1673: # Returns:
                   1674: #   list of only unique items, order not defined
                   1675: ###########################################################
                   1676: proc lunique __LIST {
                   1677:     if {[llength $__LIST]} {
                   1678:         foreach $__LIST $__LIST break
                   1679:         unset __LIST
                   1680:         return [info locals]
                   1681:     }
                   1682: }
                   1683: 
1.7       albertel 1684: ###########################################################
                   1685: # lreverse
                   1686: ###########################################################
                   1687: proc lreverse list { 
                   1688:     set result ""
                   1689:     foreach element $list { set result [linsert $result 0 $element] } 
                   1690:     return [concat $result]
                   1691: }
                   1692: 
1.1       albertel 1693: proc splitline { line maxLength } {
                   1694:     set length [string length $line]
                   1695:     set lines [expr $length/$maxLength + 1]
                   1696:     set i 0
                   1697:     while { 1 } {
                   1698: 	if { [string length $line] > $maxLength } {
                   1699: 	    set end [string wordstart $line $maxLength]
                   1700: 	    while {1} {
                   1701: 		if {[string index $line $end] == " "} {break} {incr end -1}
                   1702: 	    }
                   1703: 	    append lin [string range $line 0 [expr int($end-1)]]\n
                   1704: 	    set line [string range $line $end end]
                   1705: 	} else {
                   1706: 	    append lin $line
                   1707: 	    break
                   1708: 	}
                   1709: 	incr i
                   1710:     }
                   1711:     return $lin
                   1712: }
                   1713: 
                   1714: ###########################################################
                   1715: # winputs
                   1716: ###########################################################
                   1717: ###########################################################
                   1718: ###########################################################
                   1719: proc winputs { num message {tag normal} } {
                   1720:     global gOut
                   1721: 
                   1722:     lappend gOut(output.$num) [list $message $tag]
                   1723: }
                   1724: 
                   1725: ###########################################################
                   1726: # winoutputWrap
                   1727: ###########################################################
                   1728: ###########################################################
                   1729: ###########################################################
                   1730: proc winoutputWrap { num } {
                   1731:     global gOut 
                   1732:     if { $gOut($num.wrap) } {
                   1733: 	$gOut($num.output) configure -wrap char
                   1734:     } else {
                   1735: 	$gOut($num.output) configure -wrap none
                   1736:     }
                   1737: }
                   1738: 
                   1739: ###########################################################
                   1740: # winoutput
                   1741: ###########################################################
                   1742: ###########################################################
                   1743: ###########################################################
                   1744: proc winoutput { num cmdnum window } {
                   1745:     global gOut 
                   1746:     
                   1747:     if { ![winfo exists $window.output$num] } {
                   1748: 	set outputWin [toplevel $window.output$num]
                   1749: 	
                   1750: 	set buttonFrame [frame $outputWin.button]
                   1751: 	set textFrame [frame $outputWin.text]
                   1752: 	set bottomFrame [frame $outputWin.bottom]
                   1753: 	pack $buttonFrame $textFrame $bottomFrame
                   1754: 	pack configure $buttonFrame -anchor e -expand 0 -fill x
                   1755: 	pack configure $textFrame -expand 1 -fill both
                   1756: 	pack configure $bottomFrame -expand 0 -fill x
                   1757: 
                   1758: 	set gOut($num.output) [text $textFrame.text \
                   1759: 				  -yscrollcommand "$textFrame.scroll set" \
                   1760: 				  -xscrollcommand "$bottomFrame.scroll set"]
                   1761: 	scrollbar $textFrame.scroll -command "$textFrame.text yview"
                   1762: 	pack $gOut($num.output) $textFrame.scroll -side left
                   1763: 	pack configure $textFrame.text -expand 1 -fill both
                   1764: 	pack configure $textFrame.scroll -expand 0 -fill y
                   1765: 
                   1766: 	scrollbar $bottomFrame.scroll -command "$textFrame.text xview" -orient h
                   1767: 	pack $bottomFrame.scroll -expand 0 -fill x
                   1768: 
                   1769: 	set gOut($num.wrap) 1
                   1770: 	checkbutton $buttonFrame.wrap -text "Wrap" -command "winoutputWrap $num" \
                   1771: 	    -variable gOut($num.wrap) 
                   1772: #	button $buttonFrame.save -text "Save Text" -command "CTsaveText $num"
                   1773: 	button $buttonFrame.print -text "Print Text" -command "winprintText $num"
                   1774: 	button $buttonFrame.dismiss -text "Dismiss" -command "destroy $outputWin"
                   1775: #	pack $buttonFrame.wrap $buttonFrame.save $buttonFrame.print \
                   1776: 	    $buttonFrame.dismiss -side left
                   1777: 	pack $buttonFrame.wrap $buttonFrame.print $buttonFrame.dismiss -side left
                   1778:     }
                   1779:     set index [$gOut($num.output) index end]
                   1780:     foreach line $gOut(output.$cmdnum) {
                   1781: 	eval $gOut($num.output) insert end $line
                   1782:     }
                   1783:     unset gOut(output.$cmdnum)
                   1784:     capaRaise $window.output$num
                   1785:     $gOut($num.output) see $index
                   1786:     update idletasks
                   1787: }
                   1788: 
                   1789: ###########################################################
                   1790: # winprintText
                   1791: ###########################################################
                   1792: # prints the contents of the text window, creates a temp file named
                   1793: # quiztemp.txt
                   1794: ###########################################################
                   1795: # Arguments: num (the unique number of the path, and window)
                   1796: # Returns  : nothing
                   1797: # Globals  : gFile gCT
                   1798: ###########################################################
                   1799: proc winprintText { num } {
                   1800:     global gOut
                   1801: 
                   1802:     set window $gOut($num.output) 
                   1803:     if { ![winfo exists $window]} { return }
                   1804:     catch {parseCapaConfig $num}
                   1805:     set lprCommand [getLprCommand commontemp.txt $num]
                   1806:     if {$lprCommand == "Cancel"} { return }
                   1807:   
                   1808:     set fileId [open commontemp.txt w]
                   1809:     puts -nonewline $fileId [$window get 0.0 end-1c]
                   1810:     close $fileId
                   1811: 
                   1812:     set errorMsg ""
                   1813:     if { [catch {set output [ eval "exec $lprCommand" ] } errorMsg ]} {
                   1814:         displayError "An error occurred while printing: $errorMsg"
                   1815:     } else {
                   1816: 	displayMessage "Print job sent to the printer.\n $output"
                   1817:     }
                   1818:     exec rm -f commontemp.txt
                   1819: }
                   1820: 
                   1821: ###########################################################
                   1822: # limitEntry
                   1823: ###########################################################
                   1824: ###########################################################
                   1825: ###########################################################
                   1826: proc limitEntry { window max type {newvalue ""}} {
                   1827:     after idle "$window config -validate key"
1.3       albertel 1828:     if {($max != -1) && ([string length $newvalue] > $max)} { return 0 }
1.1       albertel 1829:     switch $type {
                   1830: 	any {}
                   1831: 	number { if {(![regexp ^\[0-9\]+$ $newvalue])&&($newvalue!="")} { return 0 } }
1.3       albertel 1832: 	letter { if {(![regexp ^\[A-Za-z\]+$ $newvalue])&& ($newvalue!="")} { return 0 }}
                   1833: 	nospace {if {(![regexp "^\[^ \]+$" $newvalue])&& ($newvalue!="")} { return 0 }}
1.1       albertel 1834:     }
                   1835:     return 1
                   1836: }
                   1837: 
1.8       albertel 1838: ###########################################################
                   1839: # getCapaID
                   1840: ###########################################################
                   1841: ###########################################################
                   1842: ###########################################################
                   1843: proc getCapaID { setinfo stunum sectionnum {path .} } {
                   1844:     global  gMaxSet
                   1845:     set pwd [pwd]
                   1846:     cd $path
                   1847:     set result ""
                   1848:     switch -regexp -- $setinfo {
                   1849: 	^[0-9]+$ {
                   1850: 	    set result [getSpecificCapaId $stunum $setinfo]
                   1851: 	}
                   1852: 	^[0-9]+\.\.[0-9]+$ {
                   1853: 	    set range [split $setinfo .]
                   1854: 	    set low [lindex $range 0]
                   1855: 	    set high [lindex $range 2]
                   1856: 	    for { set i $low } { $i <= $high } { incr i } {
                   1857: 		append result "[getSpecificCapaId $stunum $i] "
                   1858: 	    }
                   1859: 	}
                   1860: 	^[0-9]+(,[0-9]+)+$ {
                   1861: 	    set list [split $setinfo ,]
                   1862: 	    foreach set $list {
                   1863: 		append result "[getSpecificCapaId $stunum $set] "
                   1864: 	    }
                   1865: 	}
                   1866: 	all {
                   1867: 	    for { set i 1 } { $i <= $gMaxSet } { incr i } {
                   1868: 		if { [file exists [file join records date$i.db]] } {
                   1869: 		    if { [isSetOpen $stunum $sectionnum $i] } {
                   1870: 			append result "[getSpecificCapaId $stunum $i] "
                   1871: 		    }
                   1872: 		} else {
                   1873: 		    break
                   1874: 		}
                   1875: 	    }
                   1876: 	}
                   1877: 	default {
                   1878: 	    set result "UNKNOWN"
                   1879: 	}
                   1880:     }
                   1881:     cd $pwd
                   1882:     set result [string trim $result]	
                   1883:     return $result
                   1884: }
                   1885: 
                   1886: ###########################################################
                   1887: # getScores
                   1888: ###########################################################
                   1889: ###########################################################
                   1890: ###########################################################
                   1891: proc getScores { setinfo stunum sectionnum {path .} {max 99} {limitVar none}} {
                   1892:     global  gMaxSet
                   1893:     if { $limitVar != "none" } { upvar $limitVar limit }
                   1894:     set pwd [pwd]
                   1895:     cd $path
                   1896:     set result "0"
                   1897:     switch -regexp -- $setinfo {
                   1898: 	^[0-9]+$ {
                   1899: 	    if { $setinfo <= $max } {
                   1900: 		set result [format "%4d" [getScore $stunum $setinfo]]
                   1901: 	    }
                   1902: 	}
                   1903: 	^[0-9]+\.\.[0-9]+$ {
                   1904: 	    set range [split $setinfo .]
                   1905: 	    set low [lindex $range 0]
                   1906: 	    set high [lindex $range 2]
                   1907: 	    if { $high > $max } { set high $max }
                   1908: 	    for { set i $low } { $i <= $high } { incr i } {
                   1909: 		incr result [getScore $stunum $i]
                   1910: 	    }
                   1911: 	    set result [format "%4d" $result]
                   1912: 	}
                   1913: 	^[0-9]+(,[0-9]+)+$ {
                   1914: 	    set result ""
                   1915: 	    set list [split $setinfo ,]
                   1916: 	    foreach set $list {
                   1917: 		if { $set > $max } { continue }
                   1918: 		append result [format "%4d " [getScore $stunum $set]]
                   1919: 	    }
                   1920: 	}
                   1921: 	all {
                   1922: 	    for { set i 1 } { $i <= $max } { incr i } {
                   1923: 		if { [file exists [file join records date$i.db]] } {
                   1924: 		    if { [isSetOpen $stunum $sectionnum $i] } {
                   1925: 			incr result [getScore $stunum $i]
                   1926: 		    }
                   1927: 		} else {
                   1928: 		    set result [format "%4d" $result]
                   1929: 		    break
                   1930: 		}
                   1931: 	    }
                   1932: 	    set limit [expr {$i-1}]
                   1933: 	}
                   1934: 	default {
                   1935: 	    set result "UNKNOWN"
                   1936: 	}
                   1937:     }
                   1938:     cd $pwd
                   1939:     set result [string trimright $result]	
                   1940:     return $result
                   1941: }
                   1942: 
                   1943: ###########################################################
                   1944: # getScore
                   1945: ###########################################################
                   1946: ###########################################################
                   1947: ###########################################################
                   1948: proc getScore { stunum set } {
                   1949:     set fileId [open [file join records set$set.db] r]
                   1950:     set total_score 0
                   1951:     set aline [gets $fileId]
                   1952:     set weights [split [gets $fileId] {}]
                   1953:     set aline [gets $fileId]
                   1954:     set aline [gets $fileId]
                   1955:     while {! [eof $fileId]} {
                   1956: 	if {[string toupper $stunum] == [string toupper [lindex [split $aline " "] 0]]} {
                   1957: 	    set scores [lindex [split [lindex [split $aline " "] 1] ","] 0]
                   1958: 	    set scores [split $scores {}] 
                   1959: 	    for { set i 0 } { $i < [llength $scores] } { incr i } {
                   1960: 		switch -- [lindex $scores $i] {
                   1961: 		    y - Y { incr total_score [lindex $weights $i] }
                   1962: 		    n - N - e - E - - { }
                   1963: 		    0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {
                   1964: 			# catching in case weights is not as long as the record
                   1965: 			catch {incr total_score [lindex $scores $i]}
                   1966: 		    }
                   1967: 		    default { puts "Unknown character [lindex $scores $i]" }
                   1968: 		}
                   1969: 	    }
                   1970: 	    break
                   1971: 	}
                   1972: 	set aline [gets $fileId]
                   1973:     }
                   1974:     close $fileId
                   1975:     return $total_score
                   1976: }
                   1977: 
                   1978: ###########################################################
                   1979: # getTotals
                   1980: ###########################################################
                   1981: ###########################################################
                   1982: ###########################################################
                   1983: proc getTotals { setinfo stunum sectionnum {path .} {max 99} {limitVar none}} {
                   1984:     global  gMaxSet
                   1985:     if { $limitVar != "none" } { upvar $limitVar limit }
                   1986:     set pwd [pwd]
                   1987:     cd $path
                   1988:     set result "0"
                   1989:     switch -regexp -- $setinfo {
                   1990: 	^[0-9]+$ {
                   1991: 	    if { $setinfo <= $max } {
                   1992: 		set result [format "%4d" [getTotal $stunum $setinfo]]
                   1993: 	    }
                   1994: 	}
                   1995: 	^[0-9]+\.\.[0-9]+$ {
                   1996: 	    set range [split $setinfo .]
                   1997: 	    set low [lindex $range 0]
                   1998: 	    set high [lindex $range 2]
                   1999: 	    if { $high > $max } { set high $max }
                   2000: 	    for { set i $low } { $i <= $high } { incr i } {
                   2001: 		incr result [getTotal $stunum $i]
                   2002: 	    }
                   2003: 	    set result [format "%4d" $result]
                   2004: 	}
                   2005: 	^[0-9]+(,[0-9]+)+$ {
                   2006: 	    set result ""
                   2007: 	    set list [split $setinfo ,]
                   2008: 	    foreach set $list {
                   2009: 		if { $set > $max } { continue }
                   2010: 		append result [format "%4d " [getTotal $stunum $set]]
                   2011: 	    }
                   2012: 	}
                   2013: 	all {
                   2014: 	    for { set i 1 } { $i <= $max } { incr i } {
                   2015: 		if { [file exists [file join records date$i.db]] } {
                   2016: 		    if { [isSetOpen $stunum $sectionnum $i] } {
                   2017: 			incr result [getTotal $stunum $i]
                   2018: 		    }
                   2019: 		} else {
                   2020: 		    set result [format "%4d" $result]
                   2021: 		    break
                   2022: 		}
                   2023: 	    }
                   2024: 	    set limit [expr {$i-1}]
                   2025: 	}
                   2026: 	default {
                   2027: 	    set result "UNKNOWN"
                   2028: 	}
                   2029:     }
                   2030:     cd $pwd
                   2031:     set result [string trimright $result]
                   2032:     return $result
                   2033: }
                   2034: 
                   2035: ###########################################################
                   2036: # getTotal
                   2037: ###########################################################
                   2038: ###########################################################
                   2039: ###########################################################
                   2040: proc getTotal { stunum set } {
                   2041:     set fileId [open [file join records set$set.db] r]
                   2042:     set total_total 0
                   2043:     set aline [gets $fileId]
                   2044:     set weights [split [gets $fileId] {}]
                   2045:     set aline [gets $fileId]
                   2046:     set aline [gets $fileId]
                   2047:     while {! [eof $fileId]} {
                   2048: 	if {[string toupper $stunum] == [string toupper [lindex [split $aline " "] 0]]} {
                   2049: 	    set scores [lindex [split [lindex [split $aline " "] 1] ","] 0]
                   2050: 	    set scores [split $scores {}] 
                   2051: 	    for { set i 0 } { $i < [llength $scores] } { incr i } {
                   2052: 		switch -- [lindex $scores $i] {
                   2053: 		    e - E { }
                   2054: 		    0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - y - Y - n - N - - { 
1.9     ! albertel 2055: 			catch { incr total_total [lindex $weights $i] }
1.8       albertel 2056: 		    }
                   2057: 		    default { 
1.9     ! albertel 2058: 			catch { incr total_total [lindex $weights $i] }
1.8       albertel 2059: 			puts "Unknown character [lindex $scores $i]" 
                   2060: 		    }
                   2061: 		}
                   2062: 	    }
                   2063: 	    break
                   2064: 	}
                   2065: 	set aline [gets $fileId]
                   2066:     }
                   2067:     close $fileId
                   2068:     return $total_total
                   2069: }

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>