diff --git a/tcl/error.tcl b/tcl/error.tcl
index 73b3aaff..f2f15c64 100644
--- a/tcl/error.tcl
+++ b/tcl/error.tcl
@@ -179,7 +179,7 @@ proc qc::error_handler {{error_message "NULL"} args} {
}
proc qc::error_report {{error_message "NULL"} {error_info "NULL"} {error_code "NULL"}} {
- #| Return html error report. If there was a http connection when error occurred report any
+ #| Return html error report. If there was a http connection when error occurred report any
#| relevant information about http request.
# Pass in error message, info and code if available
# Otherwise will take a copy of the global error* variables for backward compatiblity
@@ -190,41 +190,41 @@ proc qc::error_report {{error_message "NULL"} {error_info "NULL"} {error_code "N
}
}
if { [ns_conn isconnected] } {
- sset html {
-
- Software Bug
- An error has occurred while processing your request.
-
- hostname:[ns_info hostname]
- url:[html_escape [qc::conn_path]]
- request:[html_escape [ns_conn request]]
- remoteip:[qc::conn_remote_ip]
- time:[qc::format_timestamp now]
- errorMessage: [html_escape $error_message]
- errorInfo:
[html_escape $error_info]
- errorCode: $error_code
-
-
Form Variables:
- [qc::error_report_form_vars]
- Cookies
- [qc::error_report_cookies]
+ sset html {
+
+ Software Bug
+ An error has occurred while processing your request.
+
+ hostname:[html_escape [ns_info hostname]]
+ url:[html_escape [qc::conn_path]]
+ request:[html_escape [ns_conn request]]
+ remoteip:[html_escape [qc::conn_remote_ip]]
+ time:[html_escape [qc::format_timestamp now]]
+ errorMessage: [html_escape $error_message]
+ errorInfo:
[html_escape $error_info]
+ errorCode: [html_escape $error_code]
+
+
Form Variables:
+ [qc::error_report_form_vars]
+ Cookies
+ [qc::error_report_cookies]
HTTP Headers
[qc::error_report_headers]
-
- }
+
+ }
} else {
- sset html {
-
- Software Bug
-
- hostname:[ns_info hostname]
- time:[qc::format_timestamp now]
- errorMessage: [html_escape $error_message]
- errorInfo:
[html_escape $error_info]
- errorCode: $error_code
-
-
- }
+ sset html {
+
+
Software Bug
+
+ hostname:[html_escape [ns_info hostname]]
+ time:[html_escape [qc::format_timestamp now]]
+ errorMessage: [html_escape $error_message]
+ errorInfo:
[html_escape $error_info]
+ errorCode: [html_escape $error_code]
+
+
+ }
}
return $html
}
@@ -236,11 +236,11 @@ proc qc::error_report_no_conn { message info code } {
Software Bug
- hostname:[ns_info hostname]
- time:[qc::format_timestamp now]
- errorMessage: $message
+ hostname:[html_escape [ns_info hostname]]
+ time:[html_escape [qc::format_timestamp now]]
+ errorMessage: [html_escape $message]
errorInfo:
[html_escape $info]
- errorCode: $code
+ errorCode: [html_escape $code]
}
@@ -249,27 +249,27 @@ proc qc::error_report_no_conn { message info code } {
proc qc::error_report_form_vars {} {
#| Return preformated html indicating values of all form variables when error occurred.
-
+
set set_id [ns_getform]
if { [string equal $set_id ""] } {
- set size 0
+ set size 0
} else {
- set size [ns_set size $set_id]
- }
+ set size [ns_set size $set_id]
+ }
set report {}
set i 0
while {$i<$size} {
- set name [ns_set key $set_id $i]
- # mask anything that looks like a card number.
- set value [ns_set value $set_id $i]
- append report "$name\n"
- # Truncate value if too long
- if { [string bytelength $value] > 1024 } {
- append report "
[string range $value 0 1023]....
"
- } else {
- append report $value
- }
- append report \n
+ set name [ns_set key $set_id $i]
+ # mask anything that looks like a card number.
+ set value [ns_set value $set_id $i]
+ append report "[html_escape $name]\n"
+ # Truncate value if too long
+ if { [string bytelength $value] > 1024 } {
+ append report "[html_escape [string range $value 0 1023]]....
"
+ } else {
+ append report [html_escape $value]
+ }
+ append report \n
incr i
}
return $report
@@ -277,19 +277,19 @@ proc qc::error_report_form_vars {} {
proc qc::error_report_locals {} {
#| Return preformated html indicating values of all local variables when error occurred.
-
+
set report {}
foreach name [uplevel 1 {info locals}] {
- # mask anything that looks like a card number.
- set value [upset 1 $name]
- append report "$name\n"
- # Truncate value if too long
- if { [string bytelength $value] > 1024 } {
- append report "[string range $value 0 1023]....
"
- } else {
- append report $value
- }
- append report \n
+ # mask anything that looks like a card number.
+ set value [upset 1 $name]
+ append report "[html_escape $name]\n"
+ # Truncate value if too long
+ if { [string bytelength $value] > 1024 } {
+ append report "[html_escape [string range $value 0 1023]]....
"
+ } else {
+ append report [html_escape $value]
+ }
+ append report \n
}
return $report
}
@@ -299,11 +299,11 @@ proc qc::error_report_cookies {} {
set cookies [ns_set iget $headers Cookie]
set report {}
foreach pair [split $cookies ;] {
- lassign [split $pair =] name value
- set name [qc::url_decode $name]
- set value [string trimright $value "; "]
- set value [qc::url_decode $value]
- append report "$name $value
"
+ lassign [split $pair =] name value
+ set name [qc::url_decode $name]
+ set value [string trimright $value "; "]
+ set value [qc::url_decode $value]
+ append report "[html_escape $name] [html_escape $value]
"
}
return $report
}
@@ -312,7 +312,7 @@ proc qc::error_report_headers {} {
set headers [ns_conn headers]
set report {}
foreach {name value} [ns_set array $headers] {
- append report "[h b $name]: [h span $value]
"
+ append report "[h b [html_escape $name]]: [h span [html_escape $value]]
"
}
return $report
}
diff --git a/test/error.test b/test/error.test
new file mode 100644
index 00000000..7f0ff384
--- /dev/null
+++ b/test/error.test
@@ -0,0 +1,192 @@
+package require tcltest
+package require mock_ns
+namespace import ::tcltest::test ::tcltest::cleanupTests ::tcltest::testConstraint mock_ns::*
+
+# Load all .tcl files
+package require fileutil
+set files [lsort [fileutil::findByPattern "~/qcode-tcl/tcl" "*.tcl"]]
+foreach file $files {
+ source $file
+}
+namespace import ::qc::*
+
+set setup {
+}
+
+set cleanup {
+ mock_ns::_reset
+}
+
+# Standard case
+test qc::error_report-1 \
+ {ns isconnected = 0} \
+ -setup $setup \
+ -cleanup $cleanup \
+ -body {
+ ns_conn _set isconnected 0
+ return [qc::error_report "Test error message" "Test error info" "TEST_ERROR_CODE"]
+ } \
+ -match glob \
+ -result {*Software Bug
*}
+
+test qc::error_report-2 \
+ {ns isconnected = 1} \
+ -setup $setup \
+ -cleanup $cleanup \
+ -body {
+ ns_conn _set protocol https
+ ns_conn _set isconnected 1
+ ns_conn _set version 1.1
+ ns_conn _set location https://test.co.uk/tcl/test.json
+ ns_conn _set port 443
+ ns_conn _set url "/tcl/test.json"
+ ns_conn _set method GET
+ ns_conn _set headers [ns_set create headers \
+ Cookie "" \
+ ]
+ ns_conn _set outputheaders [ns_set create headers]
+ ns_conn _set peeraddr 1.1.1.1
+ ns_conn _set form [ns_set create form \
+ var1 "value1" \
+ var2 [string repeat "value2" 500] \
+ ]
+ return [qc::error_report "Test error message" "Test error info" "TEST_ERROR_CODE"]
+ } \
+ -match glob \
+ -result {*Software Bug
*}
+
+test qc::error_report-3 \
+ {fallback to global args} \
+ -setup $setup \
+ -cleanup $cleanup \
+ -body {
+ ns_conn _set isconnected 0
+ set ::errorMessage "Test error message"
+ set ::errorInfo "Test error info"
+ set ::errorCode "TEST_ERROR_CODE"
+ return [qc::error_report]
+ } \
+ -match glob \
+ -result {*Software Bug
*}
+
+test qc::error_report_no_conn-1 \
+ {} \
+ -setup $setup \
+ -cleanup $cleanup \
+ -body {
+ return [qc::error_report_no_conn "Test error message" "Test error info" "TEST_ERROR_CODE"]
+ } \
+ -match glob \
+ -result {*Software Bug
*}
+
+test qc::error_report_form_vars-2 \
+ {form vars exist} \
+ -setup $setup \
+ -cleanup $cleanup \
+ -body {
+ ns_conn _set protocol https
+ ns_conn _set isconnected 1
+ ns_conn _set version 1.1
+ ns_conn _set location https://test.co.uk/tcl/test.json
+ ns_conn _set port 443
+ ns_conn _set url "/tcl/test.json"
+ ns_conn _set method GET
+ ns_conn _set headers [ns_set create headers \
+ Cookie "" \
+ ]
+ ns_conn _set outputheaders [ns_set create headers]
+ ns_conn _set peeraddr 1.1.1.1
+ ns_conn _set form [ns_set create form \
+ var1 "value1" \
+ var2 [string repeat "value2" 500] \
+ ]
+ return [qc::error_report_form_vars]
+ } \
+ -match glob \
+ -result {*var1*}
+
+test qc::error_report_form_vars-2 \
+ {no form vars} \
+ -setup $setup \
+ -cleanup $cleanup \
+ -body {
+ ns_conn _set protocol https
+ ns_conn _set isconnected 1
+ ns_conn _set version 1.1
+ ns_conn _set location https://test.co.uk/tcl/test.json
+ ns_conn _set port 443
+ ns_conn _set url "/tcl/test.json"
+ ns_conn _set method GET
+ ns_conn _set headers [ns_set create headers \
+ Cookie "" \
+ ]
+ ns_conn _set outputheaders [ns_set create headers]
+ ns_conn _set peeraddr 1.1.1.1
+ ns_conn _set form [ns_set create form]
+ return [qc::error_report_form_vars]
+ } \
+ -match glob \
+ -result {}
+
+test qc::error_report_locals-1 \
+ {} \
+ -setup $setup \
+ -cleanup $cleanup \
+ -body {
+ proc test_proc {} {
+ set var1 "value1"
+ set var2 [string repeat "value2" 500]
+ return [qc::error_report_locals]
+ }
+ return [test_proc]
+ } \
+ -match glob \
+ -result {*var1*}
+
+test qc::error_report_cookies-1 \
+ {} \
+ -setup $setup \
+ -cleanup $cleanup \
+ -body {
+ ns_conn _set protocol https
+ ns_conn _set isconnected 1
+ ns_conn _set version 1.1
+ ns_conn _set location https://test.co.uk/tcl/test.json
+ ns_conn _set port 443
+ ns_conn _set url "/tcl/test.json"
+ ns_conn _set method GET
+ ns_conn _set headers [ns_set create headers \
+ Cookie "cookie1=value1;" \
+ ]
+ ns_conn _set outputheaders [ns_set create headers]
+ ns_conn _set peeraddr 1.1.1.1
+ ns_conn _set form [ns_set create form]
+ return [qc::error_report_cookies]
+ } \
+ -match glob \
+ -result {*cookie1*}
+
+test qc::error_report_headers-1 \
+ {} \
+ -setup $setup \
+ -cleanup $cleanup \
+ -body {
+ ns_conn _set protocol https
+ ns_conn _set isconnected 1
+ ns_conn _set version 1.1
+ ns_conn _set location https://test.co.uk/tcl/test.json
+ ns_conn _set port 443
+ ns_conn _set url "/tcl/test.json"
+ ns_conn _set method GET
+ ns_conn _set headers [ns_set create headers \
+ Cookie "cookie1=value1;" \
+ ]
+ ns_conn _set outputheaders [ns_set create headers]
+ ns_conn _set peeraddr 1.1.1.1
+ ns_conn _set form [ns_set create form]
+ return [qc::error_report_headers]
+ } \
+ -match glob \
+ -result {*Cookie*}
+
+cleanupTests