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