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