38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(session:alt-out session))
(session:save-vars session)
(session:close session))
(define (stml:main proc)
(handle-exceptions
exn
(if (sdat-get-debugmode s:session)
(begin
(print "Content-type: text/html")
(print "")
(print "<html> <head> <title>EXCEPTION</title> </head> <body>")
(print " QUERY_STRING is: <b> " (get-environment-variable "QUERY_STRING") " </b> <br>")
(print "<pre>")
;; (print " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(print-error-message exn)
(print-call-chain)
(print "</pre>")
(print "<table>")
(for-each (lambda (var)
(print "<tr><td>" (car var) "</td><td>" (cdr var) "</td></tr>"))
(get-environment-variables))
(print "</table>")
(print "</body></html>"))
(begin
(print "Content-type: text/html")
(print "")
(print "<html> <head> <title>EXCEPTION</title> </head> <body>")
(print " QUERY_STRING is: <b> " (get-environment-variable "QUERY_STRING") " </b> <br>")
(print "<pre>")
;; (print " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(print-error-message exn)
(print-call-chain)
(print "</pre>")
(print "<table>")
(for-each (lambda (var)
(print "<tr><td>" (car var) "</td><td>" (cdr var) "</td></tr>"))
(get-environment-variables))
(print "</table>")
(print "</body></html>"))
(begin
(with-output-to-file (conc "/tmp/stml-crash-" (current-process-id) ".log")
(lambda ()
(print "EXCEPTION")
(print " QUERY_STRING is: " (get-environment-variable "QUERY_STRING") )
(print "")
;; (print " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
(print-error-message exn)
(print-call-chain)
(print "")
(for-each (lambda (var)
(print (car var) "\t" (cdr var)))
(get-environment-variables))))
;; return something useful to the user
(print "Content-type: text/html")
(print "")
(print "<html> <head> <title>EXCEPTION</title> </head> <body>")
(print " Please notify support at " (sdat-get-domain s:session) " that the error log is stmlcrash-" (current-process-id) ".log</b> <br>")
(print "<pre>")
;; (print " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
;; (print-error-message exn)
;; (print-call-chain)
(print "</pre>")
(print "<table>")
(for-each (lambda (var)
(print "<tr><td>" (car var) "</td><td>" (cdr var) "</td></tr>"))
(get-environment-variables))
(print "</table>")
(print "</body></html>")))
(if proc (proc s:session) (stml:cgi-session s:session))
;; (raise-error)
;; (exit)
))
|