Check-in [d4dede5804]

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

Overview
Comment:Updated to send all headers using a single header mechanism
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:d4dede5804667a7a67c30221e1035b29f7fde2da
User & Date: rkeene 2011-06-27 00:52:05
Context
2011-06-27
13:43
Corrected typo check-in: ee3526d1bc user: rkeene tags: trunk
00:52
Updated to send all headers using a single header mechanism check-in: d4dede5804 user: rkeene tags: trunk
2011-06-26
18:23
Simplified rivet_puts to use rivet_flush check-in: 181887c4ce user: rkeene tags: trunk
Changes

Changes to packages/tclrivet/tclrivet.tcl.

52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
...
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
...
243
244
245
246
247
248
249



250
251
252
253
254
255

256
257
258
259
260
261
262
...
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
...
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
				}
			}

			unset ::rivet::cache_uploads
		}

		array set ::rivet::header_pairs {}
		set ::rivet::header_type "text/html"
		set ::rivet::header_sent 0
		set ::rivet::output_buffer ""
		set ::rivet::send_no_content 0

		catch {
			namespace delete ::request
		}
................................................................................

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

		::rivet::cgi_server_writehttpheader $::rivet::statuscode

		if {![info exists ::rivet::header_redirect]} {
			tcl_puts $outchan "Content-type: $::rivet::header_type"
			foreach {var val} [array get ::rivet::header_pairs] {
				tcl_puts $outchan "$var: $val"
			}
		} else {
			tcl_puts $outchan "Location: $::rivet::header_redirect"
			tcl_puts $outchan ""
			abort_page
		}
		tcl_puts $outchan ""

		unset -nocomplain ::rivet::statuscode ::rivet::header_redirect ::rivet::header_pairs
	}

	if {!$::rivet::send_no_content && [string length $::rivet::output_buffer] != "0"} {
		if {[info exists ::rivet::transfer_encoding] && $::rivet::transfer_encoding == "chunked"} {
			fconfigure $outchan -translation "crlf"

................................................................................
	append errmsg {<p>An error has occured while processing your request.</p>} "\n"
	append errmsg "<p>This error has been assigned the case number <tt>$caseid</tt>.</p>" "\n"
	append errmsg "<p>Please reference this case number if you chose to contact the <a href=\"mailto:$::env(SERVER_ADMIN)?subject=case $caseid\">webmaster</a>" "\n"
	append errmsg {</body></html>} "\n"

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



		::rivet::cgi_server_writehttpheader 200 [string length $errmsg]
		tcl_puts $outchan "Content-type: text/html"
		tcl_puts $outchan ""
		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]
	}
................................................................................
	return [eval [rivet::parserivet $file]]
}

proc headers args {
	set cmd [lindex $args 0]
	switch -- $cmd {
		"set" {
			set var [lindex $args 1]
			set val [lindex $args 2]
			set ::rivet::header_pairs($var) $val
		}
		"add" {
			set var [lindex $args 1]
			set val [lindex $args 2]
			append ::rivet::header_pairs($var) $val
		}
		"type" {
			set val [lindex $args 1]
			set ::rivet::header_type $val
		}
		"redirect" {
			set val [lindex $args 1]
			set ::rivet::header_redirect $val
			rivet_flush
		}
		"numeric" {
................................................................................
			fconfigure $outchan -translation crlf

			tcl_puts $outchan "HTTP/1.1 $statuscode [::rivet::statuscode_to_str $statuscode]"
			tcl_puts $outchan "Date: [clock format [clock seconds] -format {%a, %d %b %Y %H:%M:%S GMT} -gmt 1]"
			tcl_puts $outchan "Server: Default"

			unset -nocomplain ::rivet::transfer_encoding









			if {$headers(CONNECTION) == "keep-alive"} {
				if {$length != -1} {
					tcl_puts $outchan "Content-Length: $length"
					tcl_puts $outchan "Connection: keep-alive"

					set ::rivet::connection "keep-alive"
				} else {
					if {$statuscode == "200"} {
						tcl_puts $outchan "Transfer-Encoding: chunked"
						tcl_puts $outchan "Connection: keep-alive"

						set ::rivet::transfer_encoding "chunked"
						set ::rivet::connection "keep-alive"
					} else {
						tcl_puts $outchan "Connection: close"

						set ::rivet::connection "close"
					}
				}
			} else {
				tcl_puts $outchan "Connection: close"

				set ::rivet::connection "close"
			}

			fconfigure $outchan -translation binary

			return

		}
	}






	tcl_puts $outchan "Status: $statuscode [::rivet::statuscode_to_str $statuscode]"




}

proc load_headers args { }

proc upload args {
	set cmd [lindex $args 0]
	set name [lindex $args 1]







|







 







<
<
<
<
<
<
<
<
<
<
<
<







 







>
>
>

<
<
<


>







 







|




|





|







 







>
>
>
>
>
>
>
>



|
|
>



|
|
>



|
>




|
>




|
|
>
|
|
>
>
>
|
>
>
|
>
>
>
>







52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
...
144
145
146
147
148
149
150












151
152
153
154
155
156
157
...
231
232
233
234
235
236
237
238
239
240
241



242
243
244
245
246
247
248
249
250
251
...
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
...
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
				}
			}

			unset ::rivet::cache_uploads
		}

		array set ::rivet::header_pairs {}
		set ::rivet::header_pairs(content-type) "text/html"
		set ::rivet::header_sent 0
		set ::rivet::output_buffer ""
		set ::rivet::send_no_content 0

		catch {
			namespace delete ::request
		}
................................................................................

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

		::rivet::cgi_server_writehttpheader $::rivet::statuscode













		unset -nocomplain ::rivet::statuscode ::rivet::header_redirect ::rivet::header_pairs
	}

	if {!$::rivet::send_no_content && [string length $::rivet::output_buffer] != "0"} {
		if {[info exists ::rivet::transfer_encoding] && $::rivet::transfer_encoding == "chunked"} {
			fconfigure $outchan -translation "crlf"

................................................................................
	append errmsg {<p>An error has occured while processing your request.</p>} "\n"
	append errmsg "<p>This error has been assigned the case number <tt>$caseid</tt>.</p>" "\n"
	append errmsg "<p>Please reference this case number if you chose to contact the <a href=\"mailto:$::env(SERVER_ADMIN)?subject=case $caseid\">webmaster</a>" "\n"
	append errmsg {</body></html>} "\n"

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

		headers type "text/html"

		::rivet::cgi_server_writehttpheader 200 [string length $errmsg]



	}

	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]
	}
................................................................................
	return [eval [rivet::parserivet $file]]
}

proc headers args {
	set cmd [lindex $args 0]
	switch -- $cmd {
		"set" {
			set var [string tolower [lindex $args 1]]
			set val [lindex $args 2]
			set ::rivet::header_pairs($var) $val
		}
		"add" {
			set var [string tolower [lindex $args 1]]
			set val [lindex $args 2]
			append ::rivet::header_pairs($var) $val
		}
		"type" {
			set val [lindex $args 1]
			set ::rivet::header_pairs(content-type) $val
		}
		"redirect" {
			set val [lindex $args 1]
			set ::rivet::header_redirect $val
			rivet_flush
		}
		"numeric" {
................................................................................
			fconfigure $outchan -translation crlf

			tcl_puts $outchan "HTTP/1.1 $statuscode [::rivet::statuscode_to_str $statuscode]"
			tcl_puts $outchan "Date: [clock format [clock seconds] -format {%a, %d %b %Y %H:%M:%S GMT} -gmt 1]"
			tcl_puts $outchan "Server: Default"

			unset -nocomplain ::rivet::transfer_encoding

			if {[info exists ::rivet::header_pairs(content-length)]} {
				set out_contentlength $::rivet::header_pairs(content-length)

				if {$length == "-1"} {
					set length $out_contentlength
				}
			}

			if {$headers(CONNECTION) == "keep-alive"} {
				if {$length != -1} {
					set ::rivet::header_pairs(content-length) $length
					set ::rivet::header_pairs(connection) "keep-alive"

					set ::rivet::connection "keep-alive"
				} else {
					if {$statuscode == "200"} {
						set ::rivet::header_pairs(transfer-encoding) "chunked"
						set ::rivet::header_pairs(connection) "keep-alive"

						set ::rivet::transfer_encoding "chunked"
						set ::rivet::connection "keep-alive"
					} else {
						set ::rivet::header_pairs(connection) "close"

						set ::rivet::connection "close"
					}
				}
			} else {
				set ::rivet::header_pairs(connection) "close"

				set ::rivet::connection "close"
			}

			fconfigure $outchan -translation binary
		}
	} else {
		tcl_puts $outchan "Status: $statuscode [::rivet::statuscode_to_str $statuscode]"
	}

	if {![info exists ::rivet::header_redirect]} {
		foreach {var val} [array get ::rivet::header_pairs] {
			tcl_puts $outchan "$var: $val"
		}
	} else {
		tcl_puts $outchan "Location: $::rivet::header_redirect"
		tcl_puts $outchan ""
		abort_page
	}

	tcl_puts $outchan ""
}

proc load_headers args { }

proc upload args {
	set cmd [lindex $args 0]
	set name [lindex $args 1]

Changes to rivet-starkit/main.tcl.

79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
...
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137





138
139
140
141
142
143
144
...
692
693
694
695
696
697
698
699
700

701
702

703
704
705
706



707
708
709
710
711
712
713
714
715
716

717
718
719
720
721
722
723
	}
	
	# Check for file existance
	if {![file exists $targetfile]} {
		if {$targetfile == "__RIVETSTARKIT_FORBIDDEN__"} {
			# Return a 403 (Forbidden)
			::rivet::cgi_server_writehttpheader 403 [array get env]
			tcl_puts $outchan "Content-type: text/html"
			tcl_puts $outchan ""
			tcl_puts $outchan "<html><head><title>Forbidden</title></head><body><h1>File Access Forbidden</h1></body>"
		} elseif {[file tail $targetfile] == "__RIVETSTARKIT_INDEX__"} {
			# Return a 403 (Forbidden)
			::rivet::cgi_server_writehttpheader 403 [array get env]
			tcl_puts $outchan "Content-type: text/html"
			tcl_puts $outchan ""
			tcl_puts $outchan "<html><head><title>Directory Listing Forbidden</title></head><body><h1>Directory Listing Forbidden</h1></body>"
		} else {
			# Return a 404 (File Not Found)
			::rivet::cgi_server_writehttpheader 404 [array get env]
			tcl_puts $outchan "Content-type: text/html"
			tcl_puts $outchan ""
			tcl_puts $outchan "<html><head><title>File Not Found</title></head><body><h1>File Not Found</h1></body>"
		}

		return
	}
	
	# Determine what to do with the file based on its filename
................................................................................
			} else {
				set env(SCRIPT_NAME) $scriptname
			}

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

				$myinterp eval [list set ::auto_path $::auto_path]
				$myinterp eval [list package require tclrivet]
				$myinterp eval [list unset -nocomplain ::env]
				$myinterp eval [list array set ::env [array get env]]
				$myinterp eval [list set ::rivet::parsestack [info script]]

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






				if {$inchan != "stdin"} {
					interp share {} $inchan $myinterp
				}
				if {$outchan != "stdout"} {
					interp share {} $outchan $myinterp
				}
				if {$elogchan != "" && $elogchan != "stderr"} {
................................................................................
	# Dump static files
	if {[info exists statictype]} {
		set filelen 0
		catch {
			set filelen [file size $targetfile]
		}

		::rivet::cgi_server_writehttpheader 200 [array get env] $filelen
		tcl_puts $outchan "Content-type: $statictype"

		catch {
			tcl_puts $outchan "Last-Modified: [clock format [file mtime $targetfile] -format {%a, %d %b %Y %H:%M:%S GMT} -gmt 1]"

			tcl_puts $outchan "Expires: Tue, 19 Jan 2038 03:14:07 GMT"
		}
		tcl_puts $outchan ""
	



		set fd [open $targetfile r]
		fconfigure $fd -encoding binary -translation {binary binary}
		fconfigure $outchan -encoding binary -translation {binary binary}

		# Do the copy in the foreground.
		catch {
			fcopy $fd $outchan
		}

		close $fd


		# Determine result
		set retval "close"
		if {[info exists ::rivet::connection]} {
			set retval $::rivet::connection
		}








<
<




<
<




<
<







 







<
<
<
<
<
<
|






>
>
>
>
>







 







|
<
>

|
>
|

<
|
>
>
>
|
|
|

|
|
|
|

|
>







79
80
81
82
83
84
85


86
87
88
89


90
91
92
93


94
95
96
97
98
99
100
...
112
113
114
115
116
117
118






119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
...
685
686
687
688
689
690
691
692

693
694
695
696
697
698

699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
	}
	
	# Check for file existance
	if {![file exists $targetfile]} {
		if {$targetfile == "__RIVETSTARKIT_FORBIDDEN__"} {
			# Return a 403 (Forbidden)
			::rivet::cgi_server_writehttpheader 403 [array get env]


			tcl_puts $outchan "<html><head><title>Forbidden</title></head><body><h1>File Access Forbidden</h1></body>"
		} elseif {[file tail $targetfile] == "__RIVETSTARKIT_INDEX__"} {
			# Return a 403 (Forbidden)
			::rivet::cgi_server_writehttpheader 403 [array get env]


			tcl_puts $outchan "<html><head><title>Directory Listing Forbidden</title></head><body><h1>Directory Listing Forbidden</h1></body>"
		} else {
			# Return a 404 (File Not Found)
			::rivet::cgi_server_writehttpheader 404 [array get env]


			tcl_puts $outchan "<html><head><title>File Not Found</title></head><body><h1>File Not Found</h1></body>"
		}

		return
	}
	
	# Determine what to do with the file based on its filename
................................................................................
			} else {
				set env(SCRIPT_NAME) $scriptname
			}

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







				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]
				$myinterp eval [list unset -nocomplain ::env]
				$myinterp eval [list array set ::env [array get env]]
				$myinterp eval [list set ::rivet::parsestack [info script]]

				if {$inchan != "stdin"} {
					interp share {} $inchan $myinterp
				}
				if {$outchan != "stdout"} {
					interp share {} $outchan $myinterp
				}
				if {$elogchan != "" && $elogchan != "stderr"} {
................................................................................
	# Dump static files
	if {[info exists statictype]} {
		set filelen 0
		catch {
			set filelen [file size $targetfile]
		}

		headers type $statictype


		catch {
			headers set "Last-Modified" "[clock format [file mtime $targetfile] -format {%a, %d %b %Y %H:%M:%S GMT} -gmt 1]"

			headers set "Expires" "Tue, 19 Jan 2038 03:14:07 GMT"
		}


		::rivet::cgi_server_writehttpheader 200 [array get env] $filelen

		if {$filelen != "0"} {
			set fd [open $targetfile r]
			fconfigure $fd -encoding binary -translation {binary binary}
			fconfigure $outchan -encoding binary -translation {binary binary}

			# Do the copy in the foreground.
			catch {
				fcopy $fd $outchan
			}

			close $fd
		}

		# Determine result
		set retval "close"
		if {[info exists ::rivet::connection]} {
			set retval $::rivet::connection
		}