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 *= *" -
571: "mail_command *= *" -
572: "IMP_color *= *" -
573: "comment_color *= *" -
574: "exam_path *= *" -
575: "quiz_path *= *" -
576: "supp_path *= *" -
577: "correction_path *= *" -
578: "default_try_val *= *" -
579: "default_prob_val *= *" -
580: "default_hint_val *= *" -
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 *= *" -
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: ###########################################################
1148: proc getString { window message {type "any"}} {
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) ""
1159: entry $valFrame.val -textvariable gPrompt(val) -validate key \
1160: -validatecommand "limitEntry %W -1 $type %P"
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:
1196: set setWin [toplevel $window.choice]
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"
1234: bind $setWin <Double-1> "set gPromptMC(ok) 1"
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
1249: update idletasks
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: ###########################################################
1443: # pickSets
1444: ###########################################################
1445: ###########################################################
1446: ###########################################################
1447: proc pickSets { setsToPickFrom mode {title "Select Sets"} {window ""}} {
1448: global gPromptPSets
1449:
1450: if { $setsToPickFrom == "" } {
1451: displayMessage "No available sets."
1452: return "Cancel"
1453: }
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 {
1483: $setList insert end [format "%3d" $set]
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"
1494: bind $dialog <Double-1> "set gPromptPSets(yes) 1"
1495:
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: }
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 {
1518: lappend setsToDo [string trim [lindex [$setList get $selection] 0]]
1519: }
1520: destroy $dialog
1521: return $setsToDo
1522: } else {
1523: destroy $dialog
1524: return Cancel
1525: }
1526: }
1527:
1528: ###########################################################
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: foreach name [array names gGetSet {*.[alhu]*}] { unset gGetSet($name) }
1540: if { [array names gGetSet exit] == "" } { set gGetSet(exit) 0 }
1541: }
1542: if { [catch {set gCapaConfig(getSet.answers_command)}] } {parseCapaConfig getSet}
1543: set command "$gCapaConfig(getSet.answers_command) $pid {} 1 $set"
1544: foreach var [array names gCapaConfig $num.*] { unset gCapaConfig($var) }
1545: set fileId [open "|$command" "r"]
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
1557: if { $gGetSet(exit) } {
1558: fileevent $fileId readable ""
1559: catch {close $fileId}
1560: return
1561: }
1562: set questNum $gGetSet($num.questNum)
1563: set aline [gets $fileId]
1564: if { $aline != "" } {
1565: switch [lindex [split $aline :] 0] {
1566: EQES { fileevent $fileId readable "getSetLine $num $fileId" }
1567: default { lappend gGetSet($num.$questNum.quest) $aline }
1568: }
1569: }
1570: if { [eof $fileId] } { getSetEnd $fileId }
1571: }
1572:
1573: ###########################################################
1574: # getSetLine
1575: ###########################################################
1576: ###########################################################
1577: ###########################################################
1578: proc getSetLine { num fileId } {
1579: global gGetSet
1580:
1581: if { $gGetSet(exit) } {
1582: fileevent $fileId readable ""
1583: catch {close $fileId}
1584: return
1585: }
1586: set aline [gets $fileId]
1587: if { $aline != "" } {
1588: switch [lindex [split $aline :] 0] {
1589: ANS {
1590: set questNum $gGetSet($num.questNum)
1591: set ans [string range $aline 4 end]
1592: set length [llength $ans]
1593: lappend gGetSet($num.$questNum.ans) [lindex $ans 0]
1594: if { ($length == 2) || ($length == 4)} {
1595: lappend gGetSet($num.$questNum.unit) [lindex $ans end]
1596: }
1597: if { ($length == 3) || ($length == 4) } {
1598: lappend gGetSet($num.$questNum.low) [lindex $ans 1]
1599: lappend gGetSet($num.$questNum.high) [lindex $ans 2]
1600: }
1601: }
1602: DONE { set gGetSet($num.maxprob) $gGetSet($num.questNum) }
1603: ERROR {
1604: fileevent $fileId readable ""
1605: displayError "Answers returned invalid message: $aline"
1606: fileevent $fileId readable "getSetLine $num $fileId"
1607: }
1608: BQES {
1609: incr gGetSet($num.questNum)
1610: fileevent $fileId readable "getSetQuestion $num $fileId"
1611: }
1612: SET { set gGetSet($num.questNum) 0 }
1613: default {}
1614: }
1615: }
1616: if { [eof $fileId] } { getSetEnd $num $fileId }
1617: }
1618:
1619: ###########################################################
1620: # getSetEnd
1621: ###########################################################
1622: ###########################################################
1623: ###########################################################
1624: proc getSetEnd { num fileId } {
1625: global gGetSet c
1626: if { [eof $fileId] } {
1627: catch {close $fileId}
1628: set command $gGetSet($num.command)
1629: foreach var [array names gGetSet "$num.*"] {
1630: set var2 [join [lrange [split $var .] 1 end] .]
1631: set array($var2) $gGetSet($var)
1632: unset gGetSet($var)
1633: }
1634: eval "$command array"
1635: }
1636: }
1637:
1638: ###########################################################
1639: # lunique --
1640: # order independent list unique proc. most efficient, but requires
1641: # __LIST never be an element of the input list
1642: # Arguments:
1643: # __LIST list of items to make unique
1644: # Returns:
1645: # list of only unique items, order not defined
1646: ###########################################################
1647: proc lunique __LIST {
1648: if {[llength $__LIST]} {
1649: foreach $__LIST $__LIST break
1650: unset __LIST
1651: return [info locals]
1652: }
1653: }
1654:
1655: ###########################################################
1656: # lreverse
1657: ###########################################################
1658: proc lreverse list {
1659: set result ""
1660: foreach element $list { set result [linsert $result 0 $element] }
1661: return [concat $result]
1662: }
1663:
1664: proc splitline { line maxLength } {
1665: set length [string length $line]
1666: set lines [expr $length/$maxLength + 1]
1667: set i 0
1668: while { 1 } {
1669: if { [string length $line] > $maxLength } {
1670: set end [string wordstart $line $maxLength]
1671: while {1} {
1672: if {[string index $line $end] == " "} {break} {incr end -1}
1673: }
1674: append lin [string range $line 0 [expr int($end-1)]]\n
1675: set line [string range $line $end end]
1676: } else {
1677: append lin $line
1678: break
1679: }
1680: incr i
1681: }
1682: return $lin
1683: }
1684:
1685: ###########################################################
1686: # winputs
1687: ###########################################################
1688: ###########################################################
1689: ###########################################################
1690: proc winputs { num message {tag normal} } {
1691: global gOut
1692:
1693: lappend gOut(output.$num) [list $message $tag]
1694: }
1695:
1696: ###########################################################
1697: # winoutputWrap
1698: ###########################################################
1699: ###########################################################
1700: ###########################################################
1701: proc winoutputWrap { num } {
1702: global gOut
1703: if { $gOut($num.wrap) } {
1704: $gOut($num.output) configure -wrap char
1705: } else {
1706: $gOut($num.output) configure -wrap none
1707: }
1708: }
1709:
1710: ###########################################################
1711: # winoutput
1712: ###########################################################
1713: ###########################################################
1714: ###########################################################
1715: proc winoutput { num cmdnum window } {
1716: global gOut
1717:
1718: if { ![winfo exists $window.output$num] } {
1719: set outputWin [toplevel $window.output$num]
1720:
1721: set buttonFrame [frame $outputWin.button]
1722: set textFrame [frame $outputWin.text]
1723: set bottomFrame [frame $outputWin.bottom]
1724: pack $buttonFrame $textFrame $bottomFrame
1725: pack configure $buttonFrame -anchor e -expand 0 -fill x
1726: pack configure $textFrame -expand 1 -fill both
1727: pack configure $bottomFrame -expand 0 -fill x
1728:
1729: set gOut($num.output) [text $textFrame.text \
1730: -yscrollcommand "$textFrame.scroll set" \
1731: -xscrollcommand "$bottomFrame.scroll set"]
1732: scrollbar $textFrame.scroll -command "$textFrame.text yview"
1733: pack $gOut($num.output) $textFrame.scroll -side left
1734: pack configure $textFrame.text -expand 1 -fill both
1735: pack configure $textFrame.scroll -expand 0 -fill y
1736:
1737: scrollbar $bottomFrame.scroll -command "$textFrame.text xview" -orient h
1738: pack $bottomFrame.scroll -expand 0 -fill x
1739:
1740: set gOut($num.wrap) 1
1741: checkbutton $buttonFrame.wrap -text "Wrap" -command "winoutputWrap $num" \
1742: -variable gOut($num.wrap)
1743: # button $buttonFrame.save -text "Save Text" -command "CTsaveText $num"
1744: button $buttonFrame.print -text "Print Text" -command "winprintText $num"
1745: button $buttonFrame.dismiss -text "Dismiss" -command "destroy $outputWin"
1746: # pack $buttonFrame.wrap $buttonFrame.save $buttonFrame.print \
1747: $buttonFrame.dismiss -side left
1748: pack $buttonFrame.wrap $buttonFrame.print $buttonFrame.dismiss -side left
1749: }
1750: set index [$gOut($num.output) index end]
1751: foreach line $gOut(output.$cmdnum) {
1752: eval $gOut($num.output) insert end $line
1753: }
1754: unset gOut(output.$cmdnum)
1755: capaRaise $window.output$num
1756: $gOut($num.output) see $index
1757: update idletasks
1758: }
1759:
1760: ###########################################################
1761: # winprintText
1762: ###########################################################
1763: # prints the contents of the text window, creates a temp file named
1764: # quiztemp.txt
1765: ###########################################################
1766: # Arguments: num (the unique number of the path, and window)
1767: # Returns : nothing
1768: # Globals : gFile gCT
1769: ###########################################################
1770: proc winprintText { num } {
1771: global gOut
1772:
1773: set window $gOut($num.output)
1774: if { ![winfo exists $window]} { return }
1775: catch {parseCapaConfig $num}
1776: set lprCommand [getLprCommand commontemp.txt $num]
1777: if {$lprCommand == "Cancel"} { return }
1778:
1779: set fileId [open commontemp.txt w]
1780: puts -nonewline $fileId [$window get 0.0 end-1c]
1781: close $fileId
1782:
1783: set errorMsg ""
1784: if { [catch {set output [ eval "exec $lprCommand" ] } errorMsg ]} {
1785: displayError "An error occurred while printing: $errorMsg"
1786: } else {
1787: displayMessage "Print job sent to the printer.\n $output"
1788: }
1789: exec rm -f commontemp.txt
1790: }
1791:
1792: ###########################################################
1793: # limitEntry
1794: ###########################################################
1795: ###########################################################
1796: ###########################################################
1797: proc limitEntry { window max type {newvalue ""}} {
1798: after idle "$window config -validate key"
1799: if {($max != -1) && ([string length $newvalue] > $max)} { return 0 }
1800: switch $type {
1801: any {}
1802: number { if {(![regexp ^\[0-9\]+$ $newvalue])&&($newvalue!="")} { return 0 } }
1803: letter { if {(![regexp ^\[A-Za-z\]+$ $newvalue])&& ($newvalue!="")} { return 0 }}
1804: nospace {if {(![regexp "^\[^ \]+$" $newvalue])&& ($newvalue!="")} { return 0 }}
1805: }
1806: return 1
1807: }
1808:
1809: ###########################################################
1810: # getCapaID
1811: ###########################################################
1812: ###########################################################
1813: ###########################################################
1814: proc getCapaID { setinfo stunum sectionnum {path .} } {
1815: global gMaxSet
1816: set pwd [pwd]
1817: cd $path
1818: set result ""
1819: switch -regexp -- $setinfo {
1820: ^[0-9]+$ {
1821: set result [getSpecificCapaId $stunum $setinfo]
1822: }
1823: ^[0-9]+\.\.[0-9]+$ {
1824: set range [split $setinfo .]
1825: set low [lindex $range 0]
1826: set high [lindex $range 2]
1827: for { set i $low } { $i <= $high } { incr i } {
1828: append result "[getSpecificCapaId $stunum $i] "
1829: }
1830: }
1831: ^[0-9]+(,[0-9]+)+$ {
1832: set list [split $setinfo ,]
1833: foreach set $list {
1834: append result "[getSpecificCapaId $stunum $set] "
1835: }
1836: }
1837: all {
1838: for { set i 1 } { $i <= $gMaxSet } { incr i } {
1839: if { [file exists [file join records date$i.db]] } {
1840: if { [isSetOpen $stunum $sectionnum $i] } {
1841: append result "[getSpecificCapaId $stunum $i] "
1842: }
1843: } else {
1844: break
1845: }
1846: }
1847: }
1848: default {
1849: set result "UNKNOWN"
1850: }
1851: }
1852: cd $pwd
1853: set result [string trim $result]
1854: return $result
1855: }
1856:
1857: ###########################################################
1858: # getScores
1859: ###########################################################
1860: ###########################################################
1861: ###########################################################
1862: proc getScores { setinfo stunum sectionnum {path .} {max 99} {limitVar none}} {
1863: global gMaxSet
1864: if { $limitVar != "none" } { upvar $limitVar limit }
1865: set pwd [pwd]
1866: cd $path
1867: set result "0"
1868: switch -regexp -- $setinfo {
1869: ^[0-9]+$ {
1870: if { $setinfo <= $max } {
1871: set result [format "%4d" [getScore $stunum $setinfo]]
1872: }
1873: }
1874: ^[0-9]+\.\.[0-9]+$ {
1875: set range [split $setinfo .]
1876: set low [lindex $range 0]
1877: set high [lindex $range 2]
1878: if { $high > $max } { set high $max }
1879: for { set i $low } { $i <= $high } { incr i } {
1880: incr result [getScore $stunum $i]
1881: }
1882: set result [format "%4d" $result]
1883: }
1884: ^[0-9]+(,[0-9]+)+$ {
1885: set result ""
1886: set list [split $setinfo ,]
1887: foreach set $list {
1888: if { $set > $max } { continue }
1889: append result [format "%4d " [getScore $stunum $set]]
1890: }
1891: }
1892: all {
1893: for { set i 1 } { $i <= $max } { incr i } {
1894: if { [file exists [file join records date$i.db]] } {
1895: if { [isSetOpen $stunum $sectionnum $i] } {
1896: incr result [getScore $stunum $i]
1897: }
1898: } else {
1899: set result [format "%4d" $result]
1900: break
1901: }
1902: }
1903: set limit [expr {$i-1}]
1904: }
1905: default {
1906: set result "UNKNOWN"
1907: }
1908: }
1909: cd $pwd
1910: set result [string trimright $result]
1911: return $result
1912: }
1913:
1914: ###########################################################
1915: # getScore
1916: ###########################################################
1917: ###########################################################
1918: ###########################################################
1919: proc getScore { stunum set } {
1920: set fileId [open [file join records set$set.db] r]
1921: set total_score 0
1922: set aline [gets $fileId]
1923: set weights [split [gets $fileId] {}]
1924: set aline [gets $fileId]
1925: set aline [gets $fileId]
1926: while {! [eof $fileId]} {
1927: if {[string toupper $stunum] == [string toupper [lindex [split $aline " "] 0]]} {
1928: set scores [lindex [split [lindex [split $aline " "] 1] ","] 0]
1929: set scores [split $scores {}]
1930: for { set i 0 } { $i < [llength $scores] } { incr i } {
1931: switch -- [lindex $scores $i] {
1932: y - Y { incr total_score [lindex $weights $i] }
1933: n - N - e - E - - { }
1934: 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {
1935: # catching in case weights is not as long as the record
1936: catch {incr total_score [lindex $scores $i]}
1937: }
1938: default { puts "Unknown character [lindex $scores $i]" }
1939: }
1940: }
1941: break
1942: }
1943: set aline [gets $fileId]
1944: }
1945: close $fileId
1946: return $total_score
1947: }
1948:
1949: ###########################################################
1950: # getTotals
1951: ###########################################################
1952: ###########################################################
1953: ###########################################################
1954: proc getTotals { setinfo stunum sectionnum {path .} {max 99} {limitVar none}} {
1955: global gMaxSet
1956: if { $limitVar != "none" } { upvar $limitVar limit }
1957: set pwd [pwd]
1958: cd $path
1959: set result "0"
1960: switch -regexp -- $setinfo {
1961: ^[0-9]+$ {
1962: if { $setinfo <= $max } {
1963: set result [format "%4d" [getTotal $stunum $setinfo]]
1964: }
1965: }
1966: ^[0-9]+\.\.[0-9]+$ {
1967: set range [split $setinfo .]
1968: set low [lindex $range 0]
1969: set high [lindex $range 2]
1970: if { $high > $max } { set high $max }
1971: for { set i $low } { $i <= $high } { incr i } {
1972: incr result [getTotal $stunum $i]
1973: }
1974: set result [format "%4d" $result]
1975: }
1976: ^[0-9]+(,[0-9]+)+$ {
1977: set result ""
1978: set list [split $setinfo ,]
1979: foreach set $list {
1980: if { $set > $max } { continue }
1981: append result [format "%4d " [getTotal $stunum $set]]
1982: }
1983: }
1984: all {
1985: for { set i 1 } { $i <= $max } { incr i } {
1986: if { [file exists [file join records date$i.db]] } {
1987: if { [isSetOpen $stunum $sectionnum $i] } {
1988: incr result [getTotal $stunum $i]
1989: }
1990: } else {
1991: set result [format "%4d" $result]
1992: break
1993: }
1994: }
1995: set limit [expr {$i-1}]
1996: }
1997: default {
1998: set result "UNKNOWN"
1999: }
2000: }
2001: cd $pwd
2002: set result [string trimright $result]
2003: return $result
2004: }
2005:
2006: ###########################################################
2007: # getTotal
2008: ###########################################################
2009: ###########################################################
2010: ###########################################################
2011: proc getTotal { stunum set } {
2012: set fileId [open [file join records set$set.db] r]
2013: set total_total 0
2014: set aline [gets $fileId]
2015: set weights [split [gets $fileId] {}]
2016: set aline [gets $fileId]
2017: set aline [gets $fileId]
2018: while {! [eof $fileId]} {
2019: if {[string toupper $stunum] == [string toupper [lindex [split $aline " "] 0]]} {
2020: set scores [lindex [split [lindex [split $aline " "] 1] ","] 0]
2021: set scores [split $scores {}]
2022: for { set i 0 } { $i < [llength $scores] } { incr i } {
2023: switch -- [lindex $scores $i] {
2024: e - E { }
2025: 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - y - Y - n - N - - {
2026: incr total_total [lindex $weights $i]
2027: }
2028: default {
2029: incr total_total [lindex $weights $i]
2030: puts "Unknown character [lindex $scores $i]"
2031: }
2032: }
2033: }
2034: break
2035: }
2036: set aline [gets $fileId]
2037: }
2038: close $fileId
2039: return $total_total
2040: }
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