Annotation of capa/capa51/GUITools/common.tcl, revision 1.2
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: ###########################################################
1138: proc getString { window message } {
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) ""
1149: entry $valFrame.val -textvariable gPrompt(val)
1150: pack $valFrame.val
1151:
1152: message $msgFrame.msg -text $message -aspect 3000
1153: pack $msgFrame.msg
1154:
1155: button $buttonFrame.select -text "Continue" -command { set gPrompt(ok) 1 }
1156: button $buttonFrame.cancel -text "Cancel" -command { set gPrompt(ok) 0 }
1157: pack $buttonFrame.select $buttonFrame.cancel -side left
1158:
1159:
1160: bind $setWin <Return> "set gPrompt(ok) 1"
1161: Centre_Dialog $setWin default
1162: update idletasks
1163: focus $setWin
1164: focus $valFrame.val
1165: capaRaise $setWin
1166: capaGrab $setWin
1167: vwait gPrompt(ok)
1168: capaGrab release $setWin
1169: destroy $setWin
1170: if { $gPrompt(ok) == 1 } {
1171: return $gPrompt(val)
1172: } else {
1173: return ""
1174: }
1175: }
1176:
1177: ###########################################################
1178: # multipleChoice
1179: ###########################################################
1180: ###########################################################
1181: ###########################################################
1182: proc multipleChoice { window message choices {single 1}} {
1183: global gPromptMC
1184:
1.2 ! albertel 1185: set setWin [toplevel $window.choice]
1.1 albertel 1186:
1187: set msgFrame [frame $setWin.msgFrame]
1188: set valFrame [frame $setWin.valFrame]
1189: set buttonFrame [frame $setWin.buttonFrame]
1190: pack $msgFrame $valFrame $buttonFrame
1191: pack configure $valFrame -expand 1 -fill both
1192:
1193: message $msgFrame.msg -text $message -aspect 3000
1194: pack $msgFrame.msg
1195:
1196: set maxWidth 1
1197: foreach choice $choices {
1198: if {[string length $choice] > $maxWidth} {set maxWidth [string length $choice]}
1199: }
1200: set selectMode extended
1201: if { $single } { set selectMode single }
1202: listbox $valFrame.val -width [expr $maxWidth + 2] \
1203: -yscrollcommand "$valFrame.scroll set" -selectmode $selectMode
1204: scrollbar $valFrame.scroll -command "$valFrame.val yview"
1205: pack $valFrame.val $valFrame.scroll -side left
1206: pack configure $valFrame.val -expand 1 -fill both
1207: pack configure $valFrame.scroll -expand 0 -fill y
1208: foreach choice $choices { $valFrame.val insert end $choice }
1209:
1210: button $buttonFrame.select -text "Continue" -command { set gPromptMC(ok) 1 }
1211: frame $buttonFrame.spacer -width 10
1212: button $buttonFrame.selectall -text "SelectAll" -command \
1213: "$valFrame.val selection set 0 end"
1214: button $buttonFrame.cancel -text "Cancel" -command { set gPromptMC(ok) 0 }
1215: if { $single } {
1216: pack $buttonFrame.select $buttonFrame.cancel -side left
1217: } else {
1218: pack $buttonFrame.select $buttonFrame.spacer \
1219: $buttonFrame.selectall $buttonFrame.cancel -side left
1220: }
1221:
1222: bind $setWin <Return> "set gPromptMC(ok) 1"
1223: Centre_Dialog $setWin default
1224: update idletasks
1225: focus $setWin
1226: capaRaise $setWin
1227: capaGrab $setWin
1228: while { 1 } {
1229: update idletasks
1230: vwait gPromptMC(ok)
1231: if { $gPromptMC(ok) != 1 } { break }
1232: set select [$valFrame.val curselection]
1233: if { $select != "" } { break }
1234: }
1235: capaGrab release $setWin
1236: destroy $setWin
1237: if { $gPromptMC(ok) == 1 } {
1238: foreach selection $select { lappend result [lindex $choices $selection] }
1239: if { [llength $result] == 1 } { set result [lindex $result 0] }
1240: return $result
1241: } else {
1242: return ""
1243: }
1244: }
1245:
1246: ###########################################################
1247: # getSetRange
1248: ###########################################################
1249: ###########################################################
1250: ###########################################################
1251: proc getSetRange { window path } {
1252: global gMaxSet gPromptGSR
1253: for { set i 1 } { $i <= $gMaxSet } { incr i } {
1254: if { ! [file exists [file join $path records "set$i.db"]] } { break }
1255: }
1256: incr i -1
1257:
1258: set setWin [toplevel $window.setselect]
1259:
1260: set msgFrame [frame $setWin.msgFrame]
1261: set valFrame [frame $setWin.calFrame]
1262: set buttonFrame [frame $setWin.buttonFrame]
1263: pack $msgFrame $valFrame $buttonFrame
1264:
1265: message $msgFrame.msg -text "Please select a set range:" -aspect 1000
1266: pack $msgFrame.msg
1267:
1268: global gSetNumberStart gSetNumberEnd
1269: scale $valFrame.start -from 1 -to $i -variable gSetNumberStart -orient h
1270: scale $valFrame.end -from 1 -to $i -variable gSetNumberEnd -orient h
1271: pack $valFrame.start $valFrame.end
1272:
1273: button $buttonFrame.select -text "Select" -command { set gPromptGSR(ok) 1 }
1274: button $buttonFrame.cancel -text "Cancel" -command { set gPromptGSR(ok) 0 }
1275: pack $buttonFrame.select $buttonFrame.cancel -side left
1276:
1277: bind $setWin <Return> "set gPromptGSR(ok) 1"
1278: Centre_Dialog $setWin default
1279: update idletasks
1280: focus $setWin
1281: capaRaise $setWin
1282: capaGrab $setWin
1283: vwait gPromptGSR(ok)
1284: capaGrab release $setWin
1285: destroy $setWin
1286: if { $gPromptGSR(ok) == 1 } {
1287: set setIdStart $gSetNumberStart
1288: set setIdEnd $gSetNumberEnd
1289: if { $setIdStart > $setIdEnd } { set setIdEnd $setIdStart }
1290: unset gSetNumberStart
1291: unset gSetNumberEnd
1292: return [list $setIdStart $setIdEnd]
1293: } else {
1294: unset gSetNumberStart
1295: unset gSetNumberEnd
1296: return ""
1297: }
1298: }
1299:
1300: ###########################################################
1301: # getOneSet
1302: ###########################################################
1303: ###########################################################
1304: ###########################################################
1305: proc getOneSet { window path } {
1306: global gMaxSet gPromptGOS
1307: for { set i 1 } { $i <= $gMaxSet } { incr i } {
1308: if { ! [file exists [file join $path records "set$i.db"]] } { break }
1309: }
1310: incr i -1
1311:
1312: set setWin [toplevel $window.setselect]
1313:
1314: set msgFrame [frame $setWin.msgFrame]
1315: set valFrame [frame $setWin.calFrame]
1316: set buttonFrame [frame $setWin.buttonFrame]
1317: pack $msgFrame $valFrame $buttonFrame
1318:
1319: message $msgFrame.msg -text "Please select a set:" -aspect 1000
1320: pack $msgFrame.msg
1321:
1322: global gSetNumber
1323: scale $valFrame.val -from 1 -to $i -variable gSetNumber -orient h
1324: pack $valFrame.val
1325:
1326: button $buttonFrame.select -text "Select" -command { set gPromptGOS(ok) 1 }
1327: button $buttonFrame.cancel -text "Cancel" -command { set gPromptGOS(ok) 0 }
1328: pack $buttonFrame.select $buttonFrame.cancel -side left
1329:
1330: bind $setWin <Return> "set gPromptGOS(ok) 1"
1331: Centre_Dialog $setWin default
1332: update idletasks
1333: focus $setWin
1334: capaRaise $setWin
1335: capaGrab $setWin
1336: vwait gPromptGOS(ok)
1337: capaGrab release $setWin
1338: destroy $setWin
1339: if { $gPromptGOS(ok) == 1 } {
1340: set setId $gSetNumber
1341: unset gSetNumber
1342: return $setId
1343: } else {
1344: unset gSetNumber
1345: return ""
1346: }
1347: }
1348:
1349: ###########################################################
1350: # pickSections
1351: ###########################################################
1352: ###########################################################
1353: ###########################################################
1354: proc pickSections { sectionsToPickFrom {title "Select Sections"} {window ""}} {
1355: global gPromptPS
1356:
1357: set dialog [toplevel $window.pickSections -borderwidth 10]
1358: wm title $dialog "Which Sections"
1359:
1360: set infoFrame [frame $dialog.info ]
1361: set sectionListFrame [frame $dialog.list -relief groove -borderwidth 5]
1362: set buttonFrame [frame $dialog.buttons -bd 10]
1363: pack $infoFrame $sectionListFrame $buttonFrame -side top -fill x
1364:
1365: message $infoFrame.msg -text $title -aspect 5000
1366: pack $infoFrame.msg
1367:
1368: set headerFrame [frame $sectionListFrame.head ]
1369: set listboxFrame [frame $sectionListFrame.listboxframe]
1370: pack $headerFrame $listboxFrame -side top
1371: pack configure $headerFrame -anchor w
1372:
1373: message $headerFrame.msg -text "Section number # of students" \
1374: -aspect 5000
1375: pack $headerFrame.msg
1376:
1377: set sectionList [ listbox $listboxFrame.list \
1378: -yscrollcommand "$listboxFrame.scroll set" \
1379: -width 30 -height 10 -selectmode extended ]
1380: scrollbar $listboxFrame.scroll \
1381: -command "$listboxFrame.list yview" \
1382: -orient v
1383: pack $sectionList $listboxFrame.scroll -side left
1384: pack configure $listboxFrame.scroll -fill y
1385:
1386: foreach section $sectionsToPickFrom {
1387: $sectionList insert end \
1388: [format "%3d %4d" [lindex $section 0]\
1389: [lindex $section 1] ]
1390: }
1391:
1392: button $buttonFrame.yes -text Continue -command {set gPromptPS(yes) 1} \
1393: -underline 0
1394: frame $buttonFrame.spacer -width 10
1395: button $buttonFrame.selectall -text "SelectAll" -command \
1396: "$sectionList selection set 0 end"
1397: button $buttonFrame.cancel -text Cancel -command { set gPromptPS(yes) 0 } \
1398: -underline 0
1399: bind $dialog <Destroy> "set gPromptPS(yes) 0"
1400:
1401: pack $buttonFrame.yes $buttonFrame.spacer \
1402: $buttonFrame.selectall $buttonFrame.cancel -side left
1403:
1404: bind $dialog <Alt-Key> break
1405:
1406: Centre_Dialog $dialog default
1407: update
1408:
1409: focus $dialog
1410: capaRaise $dialog
1411: capaGrab $dialog
1412: vwait gPromptPS(yes)
1413: capaGrab release $dialog
1414: bind $dialog <Destroy> ""
1415: if {$gPromptPS(yes)} {
1416: set selectionList [ $sectionList curselection ]
1417: set sectionsToPrint ""
1418: foreach selection $selectionList {
1419: append sectionsToPrint "[lindex [$sectionList get $selection] 0] "
1420: }
1421: destroy $dialog
1422: return $sectionsToPrint
1423: } else {
1424: destroy $dialog
1425: return Cancel
1426: }
1427: }
1428:
1429: ###########################################################
1430: # getSet
1431: ###########################################################
1432: ###########################################################
1433: ###########################################################
1434: proc getSet { pid set followupCommand {start 1}} {
1435: global gCapaConfig gGetSet gUniqueNumber
1436: set num [incr gUniqueNumber]
1437: if { $start } {
1438: set gGetSet($num.toprocess) $pid
1439: set gGetSet($num.command) $followupCommand
1440: foreach name [array names gGetSet {*.[alhu]*}] { unset gGetSet($name) }
1441: if { [array names gGetSet exit] == "" } { set gGetSet(exit) 0 }
1442: }
1443: if { [catch {set gCapaConfig(getSet.answers_command)}] } {parseCapaConfig getSet}
1444: set command "$gCapaConfig(getSet.answers_command) $pid {} {} $set"
1445: foreach var [array names gCapaConfig $num.*] { unset gCapaConfig($var) }
1446: set fileId [open "|$command" "r"]
1447: fileevent $fileId readable "getSetLine $num $fileId"
1448: update idletasks
1449: }
1450:
1451: ###########################################################
1452: # getSetQuestion
1453: ###########################################################
1454: ###########################################################
1455: ###########################################################
1456: proc getSetQuestion { num fileId } {
1457: global gGetSet
1458: if { $gGetSet(exit) } {
1459: fileevent $fileId readable ""
1460: catch {close $fileId}
1461: return
1462: }
1463: set questNum $gGetSet($num.questNum)
1464: set aline [gets $fileId]
1465: if { $aline != "" } {
1466: switch [lindex [split $aline :] 0] {
1467: EQES { fileevent $fileId readable "getSetLine $num $fileId" }
1468: default { lappend gGetSet($num.$questNum.quest) $aline }
1469: }
1470: }
1471: if { [eof $fileId] } { getSetEnd $fileId }
1472: }
1473:
1474: ###########################################################
1475: # getSetLine
1476: ###########################################################
1477: ###########################################################
1478: ###########################################################
1479: proc getSetLine { num fileId } {
1480: global gGetSet
1481:
1482: if { $gGetSet(exit) } {
1483: fileevent $fileId readable ""
1484: catch {close $fileId}
1485: return
1486: }
1487: set aline [gets $fileId]
1488: if { $aline != "" } {
1489: switch [lindex [split $aline :] 0] {
1490: ANS {
1491: set questNum $gGetSet($num.questNum)
1492: set ans [string range $aline 4 end]
1493: set length [llength $ans]
1494: lappend gGetSet($num.$questNum.ans) [lindex $ans 0]
1495: if { ($length == 2) || ($length == 4)} {
1496: lappend gGetSet($num.$questNum.unit) [lindex $ans end]
1497: }
1498: if { ($length == 3) || ($length == 4) } {
1499: lappend gGetSet($num.$questNum.low) [lindex $ans 1]
1500: lappend gGetSet($num.$questNum.high) [lindex $ans 2]
1501: }
1502: }
1503: DONE { set gGetSet($num.maxprob) $gGetSet($num.questNum) }
1504: ERROR {
1505: fileevent $fileId readable ""
1506: displayError "Answers returned invalid message: $aline"
1507: fileevent $fileId readable "getSetLine $num $fileId"
1508: }
1509: BQES {
1510: incr gGetSet($num.questNum)
1511: fileevent $fileId readable "getSetQuestion $num $fileId"
1512: }
1513: SET { set gGetSet($num.questNum) 0 }
1514: default {}
1515: }
1516: }
1517: if { [eof $fileId] } { getSetEnd $num $fileId }
1518: }
1519:
1520: ###########################################################
1521: # getSetEnd
1522: ###########################################################
1523: ###########################################################
1524: ###########################################################
1525: proc getSetEnd { num fileId } {
1526: global gGetSet c
1527: if { [eof $fileId] } {
1528: catch {close $fileId}
1529: set command $gGetSet($num.command)
1530: foreach var [array names gGetSet "$num.*"] {
1531: set var2 [join [lrange [split $var .] 1 end] .]
1532: set array($var2) $gGetSet($var)
1533: unset gGetSet($var)
1534: }
1535: eval "$command array"
1536: }
1537: }
1538:
1539: ###########################################################
1540: # lunique --
1541: # order independent list unique proc. most efficient, but requires
1542: # __LIST never be an element of the input list
1543: # Arguments:
1544: # __LIST list of items to make unique
1545: # Returns:
1546: # list of only unique items, order not defined
1547: ###########################################################
1548: proc lunique __LIST {
1549: if {[llength $__LIST]} {
1550: foreach $__LIST $__LIST break
1551: unset __LIST
1552: return [info locals]
1553: }
1554: }
1555:
1556: proc splitline { line maxLength } {
1557: set length [string length $line]
1558: set lines [expr $length/$maxLength + 1]
1559: set i 0
1560: while { 1 } {
1561: if { [string length $line] > $maxLength } {
1562: set end [string wordstart $line $maxLength]
1563: while {1} {
1564: if {[string index $line $end] == " "} {break} {incr end -1}
1565: }
1566: append lin [string range $line 0 [expr int($end-1)]]\n
1567: set line [string range $line $end end]
1568: } else {
1569: append lin $line
1570: break
1571: }
1572: incr i
1573: }
1574: return $lin
1575: }
1576:
1577: ###########################################################
1578: # winputs
1579: ###########################################################
1580: ###########################################################
1581: ###########################################################
1582: proc winputs { num message {tag normal} } {
1583: global gOut
1584:
1585: lappend gOut(output.$num) [list $message $tag]
1586: }
1587:
1588: ###########################################################
1589: # winoutputWrap
1590: ###########################################################
1591: ###########################################################
1592: ###########################################################
1593: proc winoutputWrap { num } {
1594: global gOut
1595: if { $gOut($num.wrap) } {
1596: $gOut($num.output) configure -wrap char
1597: } else {
1598: $gOut($num.output) configure -wrap none
1599: }
1600: }
1601:
1602: ###########################################################
1603: # winoutput
1604: ###########################################################
1605: ###########################################################
1606: ###########################################################
1607: proc winoutput { num cmdnum window } {
1608: global gOut
1609:
1610: if { ![winfo exists $window.output$num] } {
1611: set outputWin [toplevel $window.output$num]
1612:
1613: set buttonFrame [frame $outputWin.button]
1614: set textFrame [frame $outputWin.text]
1615: set bottomFrame [frame $outputWin.bottom]
1616: pack $buttonFrame $textFrame $bottomFrame
1617: pack configure $buttonFrame -anchor e -expand 0 -fill x
1618: pack configure $textFrame -expand 1 -fill both
1619: pack configure $bottomFrame -expand 0 -fill x
1620:
1621: set gOut($num.output) [text $textFrame.text \
1622: -yscrollcommand "$textFrame.scroll set" \
1623: -xscrollcommand "$bottomFrame.scroll set"]
1624: scrollbar $textFrame.scroll -command "$textFrame.text yview"
1625: pack $gOut($num.output) $textFrame.scroll -side left
1626: pack configure $textFrame.text -expand 1 -fill both
1627: pack configure $textFrame.scroll -expand 0 -fill y
1628:
1629: scrollbar $bottomFrame.scroll -command "$textFrame.text xview" -orient h
1630: pack $bottomFrame.scroll -expand 0 -fill x
1631:
1632: set gOut($num.wrap) 1
1633: checkbutton $buttonFrame.wrap -text "Wrap" -command "winoutputWrap $num" \
1634: -variable gOut($num.wrap)
1635: # button $buttonFrame.save -text "Save Text" -command "CTsaveText $num"
1636: button $buttonFrame.print -text "Print Text" -command "winprintText $num"
1637: button $buttonFrame.dismiss -text "Dismiss" -command "destroy $outputWin"
1638: # pack $buttonFrame.wrap $buttonFrame.save $buttonFrame.print \
1639: $buttonFrame.dismiss -side left
1640: pack $buttonFrame.wrap $buttonFrame.print $buttonFrame.dismiss -side left
1641: }
1642: set index [$gOut($num.output) index end]
1643: foreach line $gOut(output.$cmdnum) {
1644: eval $gOut($num.output) insert end $line
1645: }
1646: unset gOut(output.$cmdnum)
1647: capaRaise $window.output$num
1648: $gOut($num.output) see $index
1649: update idletasks
1650: }
1651:
1652: ###########################################################
1653: # winprintText
1654: ###########################################################
1655: # prints the contents of the text window, creates a temp file named
1656: # quiztemp.txt
1657: ###########################################################
1658: # Arguments: num (the unique number of the path, and window)
1659: # Returns : nothing
1660: # Globals : gFile gCT
1661: ###########################################################
1662: proc winprintText { num } {
1663: global gOut
1664:
1665: set window $gOut($num.output)
1666: if { ![winfo exists $window]} { return }
1667: catch {parseCapaConfig $num}
1668: set lprCommand [getLprCommand commontemp.txt $num]
1669: if {$lprCommand == "Cancel"} { return }
1670:
1671: set fileId [open commontemp.txt w]
1672: puts -nonewline $fileId [$window get 0.0 end-1c]
1673: close $fileId
1674:
1675: set errorMsg ""
1676: if { [catch {set output [ eval "exec $lprCommand" ] } errorMsg ]} {
1677: displayError "An error occurred while printing: $errorMsg"
1678: } else {
1679: displayMessage "Print job sent to the printer.\n $output"
1680: }
1681: exec rm -f commontemp.txt
1682: }
1683:
1684: ###########################################################
1685: # limitEntry
1686: ###########################################################
1687: ###########################################################
1688: ###########################################################
1689: proc limitEntry { window max type {newvalue ""}} {
1690: after idle "$window config -validate key"
1691: if {[string length $newvalue] > $max } { return 0 }
1692: switch $type {
1693: any {}
1694: number { if {(![regexp ^\[0-9\]+$ $newvalue])&&($newvalue!="")} { return 0 } }
1695: letter {if {(![regexp ^\[A-Za-z\]+$ $newvalue])&& ($newvalue!="")} { return 0 }}
1696: }
1697: return 1
1698: }
1699:
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