Check-in [d1dc76a920]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Updated so that logging works with threads correctly
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:d1dc76a92039085b4b6d861beccc1249ea917ff9
User & Date: rkeene 2015-05-23 01:48:56
Context
2015-05-23
01:59
Updated to return a 500 error when we generate a rivet_error check-in: 65bf739985 user: rkeene tags: trunk
01:48
Updated so that logging works with threads correctly check-in: d1dc76a920 user: rkeene tags: trunk
2014-11-05
19:09
rivetcgi 0.5.1.7 check-in: e81ec0430d user: rkeene tags: trunk, 0.5.1.7
Changes

Changes to packages/tclrivet/tclrivet.tcl.

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
...
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
...
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
...
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
...
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
proc rivet_flush args {
	set final_flush 0
	if {[lsearch -exact $args "-final"] != "-1"} {
		set final_flush 1
	}

	set outchan stdout
	if {[info exists ::env(RIVET_INTERFACE)]} {
		set outchan [lindex $::env(RIVET_INTERFACE) 2]
		array set headers [lindex $::env(RIVET_INTERFACE) 4]
	}

	if {!$::rivet::header_sent} {
		set ::rivet::header_sent 1

		if {![info exists ::rivet::statuscode]} {
			set ::rivet::statuscode 200
................................................................................

	set ::rivet::output_buffer ""
}

proc rivet_error {} {
	set outchan stdout
	set errchan stderr
	if {[info exists ::env(RIVET_INTERFACE)]} {
		set outchan [lindex $::env(RIVET_INTERFACE) 2]
		set errchan [lindex $::env(RIVET_INTERFACE) 3]
	}

	global errorInfo
	if {[info exists errorInfo]} {
		set incoming_errorInfo $errorInfo
	} else {
		set incoming_errorInfo "<<NO ERROR>>"
................................................................................
	}

	tcl_puts -nonewline $outchan $errmsg
}

proc rivet_puts args {
	set outchan stdout
	if {[info exists ::env(RIVET_INTERFACE)]} {
		set outchan [lindex $::env(RIVET_INTERFACE) 2]
	}

	if {[lindex $args 0] == "-nonewline"} {
		set appendchar ""
		set args [lrange $args 1 end]
	} else {
		set appendchar "\n"
................................................................................
	set defval [lindex $args 2]

	return [::rivet::_var all $cmd $var $defval]
}

proc ::rivet::_var args {
	set inchan stdin
	if {[info exists ::env(RIVET_INTERFACE)]} {
		set inchan [lindex $::env(RIVET_INTERFACE) 1]
	}

	if {![info exists ::rivet::cache_vars]} {
		global env
		array set ::rivet::cache_vars {}
		array set ::rivet::cache_vars_qs {}
		array set ::rivet::cache_vars_post {}
................................................................................
		upvar ::env env
	} else {
		array set env $useenv
	}

	set outchan stdout

	if {[info exists env(RIVET_INTERFACE)]} {
		set outchan [lindex $env(RIVET_INTERFACE) 2]
		array set headers [lindex $env(RIVET_INTERFACE) 4]

		if {[lindex $env(RIVET_INTERFACE) 0] == "FULLHEADERS"} {
			fconfigure $outchan -translation crlf

			if {[info exists ::rivet::header_redirect]} {
				set statuscode 302
			}

			tcl_puts $outchan "HTTP/1.1 $statuscode [::rivet::statuscode_to_str $statuscode]"







|
|
|







 







|
|
|







 







|
|







 







|
|







 







|
|
|

|







132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
...
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
...
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
...
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
...
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
proc rivet_flush args {
	set final_flush 0
	if {[lsearch -exact $args "-final"] != "-1"} {
		set final_flush 1
	}

	set outchan stdout
	if {[info exists ::rivetstarkit::RIVET_INTERFACE]} {
		set outchan [lindex $::rivetstarkit::RIVET_INTERFACE 2]
		array set headers [lindex $::rivetstarkit::RIVET_INTERFACE 4]
	}

	if {!$::rivet::header_sent} {
		set ::rivet::header_sent 1

		if {![info exists ::rivet::statuscode]} {
			set ::rivet::statuscode 200
................................................................................

	set ::rivet::output_buffer ""
}

proc rivet_error {} {
	set outchan stdout
	set errchan stderr
	if {[info exists ::rivetstarkit::RIVET_INTERFACE]} {
		set outchan [lindex $::rivetstarkit::RIVET_INTERFACE 2]
		set errchan [lindex $::rivetstarkit::RIVET_INTERFACE 3]
	}

	global errorInfo
	if {[info exists errorInfo]} {
		set incoming_errorInfo $errorInfo
	} else {
		set incoming_errorInfo "<<NO ERROR>>"
................................................................................
	}

	tcl_puts -nonewline $outchan $errmsg
}

proc rivet_puts args {
	set outchan stdout
	if {[info exists ::rivetstarkit::RIVET_INTERFACE]} {
		set outchan [lindex $::rivetstarkit::RIVET_INTERFACE 2]
	}

	if {[lindex $args 0] == "-nonewline"} {
		set appendchar ""
		set args [lrange $args 1 end]
	} else {
		set appendchar "\n"
................................................................................
	set defval [lindex $args 2]

	return [::rivet::_var all $cmd $var $defval]
}

proc ::rivet::_var args {
	set inchan stdin
	if {[info exists ::rivetstarkit::RIVET_INTERFACE]} {
		set inchan [lindex $::rivetstarkit::RIVET_INTERFACE 1]
	}

	if {![info exists ::rivet::cache_vars]} {
		global env
		array set ::rivet::cache_vars {}
		array set ::rivet::cache_vars_qs {}
		array set ::rivet::cache_vars_post {}
................................................................................
		upvar ::env env
	} else {
		array set env $useenv
	}

	set outchan stdout

	if {[info exists ::rivetstarkit::RIVET_INTERFACE]} {
		set outchan [lindex $::rivetstarkit::RIVET_INTERFACE 2]
		array set headers [lindex $::rivetstarkit::RIVET_INTERFACE 4]

		if {[lindex $::rivetstarkit::RIVET_INTERFACE 0] == "FULLHEADERS"} {
			fconfigure $outchan -translation crlf

			if {[info exists ::rivet::header_redirect]} {
				set statuscode 302
			}

			tcl_puts $outchan "HTTP/1.1 $statuscode [::rivet::statuscode_to_str $statuscode]"

Changes to rivet-starkit/main.tcl.

13
14
15
16
17
18
19

20
21
22
23
24
25
26
27
28
29
30
...
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
...
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
...
761
762
763
764
765
766
767
768



























































769


770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
...
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
....
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
....
1327
1328
1329
1330
1331
1332
1333
1334

1335
1336
1337
1338
1339
1340
1341
	} else {
		array set env $useenv
	}

	set inchan stdout
	set outchan stdout
	set elogchan ""

	if {[info exists env(RIVET_INTERFACE)]} {
		set inchan [lindex $env(RIVET_INTERFACE) 1]
		set outchan [lindex $env(RIVET_INTERFACE) 2]
		set elogchan [lindex $env(RIVET_INTERFACE) 3]
	}

	# Determine if a sub-file has been requested
	## Sanity check
	set indexfiles [list index.rvt index.html index.htm __RIVETSTARKIT_INDEX__]
	if {[info exists env(PATH_INFO)]} {
		if {[string match "*..*" $env(PATH_INFO)]} {
................................................................................
			}

			if {$createinterp} {
				set myinterp [interp create]

				interp alias $myinterp exit {} ::rivetstarkit::destroy_interp $myinterp

				foreach var [list ::starkit::topdir ::auto_path] {
					if {[namespace qualifiers $var] != ""} {
						$myinterp eval [list namespace eval [namespace qualifiers $var] ""]
					}
					$myinterp eval [list set $var [set $var]]
				}

				$myinterp eval [list package require tclrivet]
................................................................................

				if {$inchan != "stdin"} {
					interp share {} $inchan $myinterp
				}
				if {$outchan != "stdout"} {
					interp share {} $outchan $myinterp
				}
				if {$elogchan != "" && $elogchan != "stderr"} {
					interp share {} $elogchan $myinterp
				}

				if {[catch {
					$myinterp eval [list parse $targetfile]
				} err]} {
					if {[info command $myinterp] != ""} {
................................................................................
		}

		return $retval
	}

	return "unknown"
}




























































proc ::rivetstarkit::puts_log {logfd msg} {


	if {$logfd == ""} {
		return
	}

	catch {
		tcl_puts $logfd $msg

		flush $logfd
	}
}

proc ::rivetstarkit::destroy_interp {interp args} {
	interp delete $interp
}

................................................................................
	}
	unset canfork

	if {$initscp != ""} {
		uplevel #0 $initscp
	}

	switch -- $logfile {
		"-" {
			set logfd stdout
		}
		"" {
			set logfd ""
		}
		default {
			set logfile [file join [file dirname [file dirname [info script]]] $logfile]
			set logfd [open $logfile a]
		}
	}

	switch -- $errorlogfile {
		"-" {
			set elogfd stderr
		}
		"" {
			set elogfd stderr
			catch {
				set elogfd [open /dev/null a]
			}
		}
		default {
			set errorlogfile [file join [file dirname [file dirname [info script]]] $errorlogfile]
			set elogfd [open $errorlogfile a]
		}
	}

	catch {
		wm withdraw .
	}

	if {$elogfd == "stderr" || $logfd == "stdout"} {
		catch {
			console show
		}
	}

	foreach port $ports {
		if {[string match "ssl:*" $port]} {
................................................................................
		"thread-parent" {
			set pmodel "thread"

			# Transfer the socket to the thread, and specify our thread Id
			thread::transfer $threadId $sock

			::rivetstarkit::puts_log $elogfd "Calling child thread to handle request ($threadId) in background"
			thread::send -async $threadId [list rivet_cgi_server_request $hostport "" "" "thread-child" 0 $httpmode $sock $addr $port [thread::id]]
			::rivetstarkit::puts_log $elogfd " ... done ($threadId)."

			return
		}
		"thread-child" {
			set pmodel "thread"

................................................................................
			}
			if {[info exists ::env(PATH)]} {
				set myenv(PATH) $::env(PATH)
			}

			# Add Rivet Interface specification to fake environment, so further
			# Rivet/CGI knows how to interface
			set myenv(RIVET_INTERFACE) [list FULLHEADERS $sock $sock $elogfd [array get headers]]


			# Set TLS Socket Info
			array set tlsinfo_peer [list sbits 0]
			array set tlsinfo_local [list sbits 0]
			catch {
				array set tlsinfo_peer [tls::status $sock]








>
|
|
|
|







 







|







 







|







 








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>
|




|

|







 







|
<
<
<
<
|
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<





|







 







|







 







|
>







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
...
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
...
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
...
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
...
942
943
944
945
946
947
948
949




950







951














952
953
954
955
956
957
958
959
960
961
962
963
964
....
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
....
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
	} else {
		array set env $useenv
	}

	set inchan stdout
	set outchan stdout
	set elogchan ""

	if {[info exists ::rivetstarkit::RIVET_INTERFACE]} {
		set inchan [lindex $::rivetstarkit::RIVET_INTERFACE 1]
		set outchan [lindex $::rivetstarkit::RIVET_INTERFACE 2]
		set elogchan [lindex $::rivetstarkit::RIVET_INTERFACE 3]
	}

	# Determine if a sub-file has been requested
	## Sanity check
	set indexfiles [list index.rvt index.html index.htm __RIVETSTARKIT_INDEX__]
	if {[info exists env(PATH_INFO)]} {
		if {[string match "*..*" $env(PATH_INFO)]} {
................................................................................
			}

			if {$createinterp} {
				set myinterp [interp create]

				interp alias $myinterp exit {} ::rivetstarkit::destroy_interp $myinterp

				foreach var [list ::starkit::topdir ::auto_path ::rivetstarkit::RIVET_INTERFACE] {
					if {[namespace qualifiers $var] != ""} {
						$myinterp eval [list namespace eval [namespace qualifiers $var] ""]
					}
					$myinterp eval [list set $var [set $var]]
				}

				$myinterp eval [list package require tclrivet]
................................................................................

				if {$inchan != "stdin"} {
					interp share {} $inchan $myinterp
				}
				if {$outchan != "stdout"} {
					interp share {} $outchan $myinterp
				}
				if {$elogchan != "stderr"} {
					interp share {} $elogchan $myinterp
				}

				if {[catch {
					$myinterp eval [list parse $targetfile]
				} err]} {
					if {[info command $myinterp] != ""} {
................................................................................
		}

		return $retval
	}

	return "unknown"
}

proc ::rivetstarkit::logFdToRealFd {logfd} {

	set type [lindex $logfd 0]
	set filename [lindex $logfd 1]

	if {$filename == ""} {
		return ""
	}

	if {[info exists ::rivetstarkit::logfdcache($filename)]} {
		set fd $::rivetstarkit::logfdcache($filename)
	} else {
		switch -- $filename {
			"-" {
				switch -- $type {
					"LOG" {
						set destination stdout
					}
					"ERROR" {
						set destination stderr
					}
				}

			}
			"stdout" - "stderr" {
				set destination $filename
			}
			default {
				set filename [file join [file dirname [file dirname [info script]]] $filename]

				catch {
					set fd [open $filename a]
				}
				if {![info exists fd]} {
					catch {
						set fd [open $filename w]
					}
				}
			}
		}

		if {[info exists destination] && ![info exists fd]} {
			if {$::rivetstarkit::process_model == "thread"} {
				set fd [open "/dev/$destination" w]
			} else {
				set fd $destination
			}
		}

		if {![info exists fd]} {
			return ""
		}

		set ::rivetstarkit::logfdcache($filename) $fd
	}

	return $fd
}

proc ::rivetstarkit::puts_log {logfd msg} {
	set fd [::rivetstarkit::logFdToRealFd $logfd]

	if {$fd == ""} {
		return
	}

	catch {
		tcl_puts $fd $msg

		flush $fd
	}
}

proc ::rivetstarkit::destroy_interp {interp args} {
	interp delete $interp
}

................................................................................
	}
	unset canfork

	if {$initscp != ""} {
		uplevel #0 $initscp
	}

	set ::rivetstarkit::process_model $process_model




	set logfd [list "LOG" $logfile]







	set elogfd [list "ERROR" $errorlogfile]















	catch {
		wm withdraw .
	}

	if {$errorlogfile == "-" || $logfile == "-"} {
		catch {
			console show
		}
	}

	foreach port $ports {
		if {[string match "ssl:*" $port]} {
................................................................................
		"thread-parent" {
			set pmodel "thread"

			# Transfer the socket to the thread, and specify our thread Id
			thread::transfer $threadId $sock

			::rivetstarkit::puts_log $elogfd "Calling child thread to handle request ($threadId) in background"
			thread::send -async $threadId [list rivet_cgi_server_request $hostport $logfd $elogfd "thread-child" 0 $httpmode $sock $addr $port [thread::id]]
			::rivetstarkit::puts_log $elogfd " ... done ($threadId)."

			return
		}
		"thread-child" {
			set pmodel "thread"

................................................................................
			}
			if {[info exists ::env(PATH)]} {
				set myenv(PATH) $::env(PATH)
			}

			# Add Rivet Interface specification to fake environment, so further
			# Rivet/CGI knows how to interface
			namespace eval ::rivetstarkit {}
			set ::rivetstarkit::RIVET_INTERFACE [list FULLHEADERS $sock $sock [::rivetstarkit::logFdToRealFd $elogfd] [array get headers]]

			# Set TLS Socket Info
			array set tlsinfo_peer [list sbits 0]
			array set tlsinfo_local [list sbits 0]
			catch {
				array set tlsinfo_peer [tls::status $sock]