1: #!/usr/local/bin/tclsh8.0
2:
3: proc outputHeader { } {
4: puts "Content-type: text/html\n\n<HTML><TITLE></TITLE><BODY bgcolor=\"#ffffff\"> "
5: }
6:
7: proc outputFooter {} {
8: puts "</BODY></HTML>"
9: }
10:
11: proc getid.outputButton { capaid argumentsVar } {
12: global machine
13: upvar $argumentsVar arguments
14: puts "<FORM METHOD=\"POST\" ACTION=\"http://$machine/capa-bin/capahtml\">"
15: puts "<input type=\"HIDDEN\" name=\"M\" value=1>"
16: puts "<input type=\"HIDDEN\" name=\"CAPAID\" value=$capaid>"
17: puts "<input type=\"HIDDEN\" name=\"SNUM\" value=$arguments(SNUM)>"
18: puts "<input type=\"HIDDEN\" name=\"CLASS\" value=$arguments(CLASS)>"
19: puts "Click <input type=\"submit\" value=\" here \"> to work on <i>CAPA</i>."
20: puts "</form>"
21: }
22:
23: proc getid.main {argumentsVar} {
24: global config classList
25: upvar $argumentsVar arguments
26: outputHeader
27: if { [array names classList $arguments(CLASS).path] != "" } {
28: set pwd [pwd]
29: catch {cd $classList($arguments(CLASS).path)} error
30: # puts "hey :$error:"
31: catch {set result [exec $config(webpage) -getid $arguments(SNUM) \
32: $arguments(SETID) $arguments(CAPAID) ]} error
33: # puts "hey :$error:"
34: # puts "hey :$error:$result:"
35: switch $result {
36: InvalidSetId { puts "The set requested, $arguments(SETID), is not a valid set number." }
37: InvalidOldCapaID -
38: NotFound { puts "The provided old <i>CAPA</i>ID ($arguments(CAPAID)) is not a valid <i>CAPA</i>ID for any set previous to the requested set $arguments(SETID)." }
39: NotOpen { puts "The set requested, $arguments(SETID), is not open." }
40: default { puts "Your <i>CAPA</i>ID is <font size=+2>$result</font> for Set $arguments(SETID) in class $arguments(CLASS)."; getid.outputButton $result arguments}
41: }
42: cd $pwd
43: } else {
44: puts "Invalid request. Class $arguments(CLASS) not found."
45: }
46: outputFooter
47: }
48:
49: proc capaid.outputButton { capaid argumentsVar } {
50: global machine
51: upvar $argumentsVar arguments
52: puts "<FORM METHOD=\"POST\" ACTION=\"http://$machine/capa-bin/capahtml\">"
53: puts "<input type=\"HIDDEN\" name=\"M\" value=1>"
54: puts "<input type=\"HIDDEN\" name=\"CAPAID\" value=$capaid>"
55: puts "<input type=\"HIDDEN\" name=\"SNUM\" value=$arguments(SNUM)>"
56: puts "<input type=\"HIDDEN\" name=\"CLASS\" value=$arguments(CLASS)>"
57: puts "Click <input type=\"submit\" value=\" here \"> to work on <i>CAPA</i>."
58: puts "</form>"
59: }
60:
61: proc capaid.main {argumentsVar} {
62: global config classList
63: upvar $argumentsVar arguments
64: outputHeader
65: if { [array names classList $arguments(CLASS).path] != "" } {
66: set pwd [pwd]
67: catch {cd $classList($arguments(CLASS).path)} error
68: # puts "hey :$error:"
69: catch {set result [exec $config(webpage) -getid $arguments(SNUM) \
70: $arguments(SETID)]} error
71: # puts "hey :$error:"
72: # puts "hey :$error:$result:"
73: switch $result {
74: InvalidSetId { puts "The set requested, $arguments(SETID), is not a valid set number." }
75: InvalidOldCapaID -
76: NotFound { puts "The provided Student Number $arguments(SNUM) is not a valid for $arguments(CLASS)." }
77: NotOpen { puts "The set requested, $arguments(SETID), is not open." }
78: default { puts "Your <i>CAPA</i>ID is <font size=+2>$result</font> for Set $arguments(SETID) in class $arguments(CLASS)."; capaid.outputButton $result arguments}
79: }
80: cd $pwd
81: } else {
82: puts "Invalid request. Class $arguments(CLASS) not found."
83: }
84: outputFooter
85: }
86:
87: proc emailid.sendmail { what who argumentsVar } {
88: global config
89: upvar $argumentsVar arguments
90: if { $who == "" } {
91: puts "There is no e-mail address available for this student. Please contact you r instructor to obtain your <i>CAPA</i>ID."
92: } else {
93: set mailID [open "|$config(mail) -s \"Requested CAPAID\" $who" w]
94: puts $mailID "The CAPAID you requested for class $arguments(CLASS), set number $arguments(SETID) is $what."
95: close $mailID
96: puts "Your <i>CAPA</i>ID has been mailed to your university e-mail account."
97: }
98: }
99:
100: proc emailid.main {argumentsVar} {
101: global classList config
102: upvar $argumentsVar arguments
103: outputHeader
104: if { [array names classList $arguments(CLASS).path] != "" } {
105: set pwd [pwd]
106: if {[catch {cd $classList($arguments(CLASS).path)} error ]} {
107: puts $error; return
108: }
109: if {[catch {set result [exec $config(webpage) -emailcapaid $arguments(SNUM) \
110: $arguments(SETID) ]} error ]} {
111: puts $error; return
112: }
113: cd $pwd
114: switch $result {
115: InvalidSetId { puts "The set requested, $arguments(SETID), is not a valid set number." }
116: NotOpen { puts "The set requested, $arguments(SETID), is not yet open for access." }
117: NotFound { puts "Unable to find student number $arguments(SNUM) in classlist."}
118: default {
119: if { [catch { eval "emailid.sendmail $result arguments" } error ] } {
120: puts "$error:There is no e-mail address available for this student. Please contact your instructor to obtain your <i>CAPA</i>ID."
121: }
122: }
123: }
124: } else {
125: puts "Invalid request. Class $arguments(CLASS) not found."
126: }
127:
128: outputFooter
129: }
130:
131: proc getSettings { } {
132: global classList
133: set confID [open "class.conf"]
134: set aline [gets $confID]
135: while {![eof $confID]} {
136: set class [lindex $aline 0]
137: set path [lindex $aline 1]
138: set classList($class.path) [file join $path $class]
139: set aline [gets $confID]
140: }
141: }
142:
143: proc ids.main {} {
144: global env
145: getSettings
146: set request [string trim [read file0]]
147: foreach {var value} [split $request "&="] {set arguments($var) [string trim $value]}
148: catch {set arguments(SETID) [string trimleft $arguments(SETID) 0]}
149: catch {set logFileId [open ids.log "a"]} error
150:
151: set b [split $request "&="]
152: if { [catch {lappend b $env(REMOTE_HOST)}]} {
153: if { [catch {lappend b $env(REMOTE_ADDR)}] } {
154: lappend b UNKNOWN
155: }
156: }
157: puts $logFileId "[clock format [clock seconds]] $b"
158: close $logFileId
159:
160: $arguments(TYPE).main arguments
161: }
162:
163: proc optionlist { match } {
164: global env
165: set request ""
166: catch {puts $env(QUERY_STRING)}
167: catch {set request [string trim $env(QUERY_STRING)]}
168: if { $request == "" } {
169: set arguments(CLASS) ""
170: } else {
171: foreach {var value} [split $request "&="] {set arguments($var) [string trim $value]}
172: }
173: set confID [open "class.conf"]
174: set aline [gets $confID]
175: while {!([eof $confID] && ($aline == ""))} {
176: set type [lindex $aline 3]
177: if { [lsearch $type $match] != -1 } {
178: set classname [lindex $aline 0]
179: if { [string toupper $classname] == [string toupper $arguments(CLASS)] } {
180: puts "<option selected> [lindex $aline 0]"
181: } else {
182: puts "<option> [lindex $aline 0]"
183: }
184: }
185: set aline [gets $confID]
186: }
187: }
188:
189: proc main {} {
190: global argv0 machine class.head class.tail emailid.head emailid.tail \
191: getid.head getid.tail capaid.head capaid.tail config
192: eval "global [info globals]"
193: source web.settings
194: switch -glob -- [file tail $argv0] {
195: class.* -
196: index.* {
197: puts "Content-type: text/html\n\n"
198: puts [subst -nocommands ${class.head}]
199: optionlist class
200: puts [subst -nocommands ${class.tail}]
201: }
202: emailid.* {
203: puts "Content-type: text/html\n\n"
204: puts [subst -nocommands ${emailid.head}]
205: optionlist emailid
206: puts [subst -nocommands ${emailid.tail}]
207: }
208: getid.* {
209: puts "Content-type: text/html\n\n"
210: puts [subst -nocommands ${getid.head}]
211: optionlist getid
212: puts [subst -nocommands ${getid.tail}]
213: }
214: capaid.* {
215: puts "Content-type: text/html\n\n"
216: puts [subst -nocommands ${capaid.head}]
217: optionlist capaid
218: puts [subst -nocommands ${capaid.tail}]
219: }
220: default { ids.main }
221: }
222: }
223:
224: main
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to webpage.tcl CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / capa / capa51 / GUITools