scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

bug removal; add data table to result output

This commit is contained in:
interp 2002-10-02 23:45:35 +00:00
parent 20ff8816a9
commit 4899ff0453
1 changed files with 39 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm
View File

@ -6,11 +6,16 @@
profiling profiling
handle-fatal-error handle-fatal-error
httpd-responses httpd-responses
(subset srfi-1 (iota))
let-opt let-opt
) )
(begin (begin
(define file-name (create-temp-file "servlet-profiling")) ;; This uses the filesystem heavily to not influence the
;; profiling. Note to get the resulting picture, gnuplot must be
;; installed.
(define file-name #f)
(define file-names-to-delete '()) (define file-names-to-delete '())
(define (add-file-name-to-delete! file-name) (define (add-file-name-to-delete! file-name)
(set! file-names-to-delete (cons file-name file-names-to-delete))) (set! file-names-to-delete (cons file-name file-names-to-delete)))
@ -49,16 +54,18 @@
"Delete files and reset profile state.")))) "Delete files and reset profile state."))))
(hr) (hr)
(URL ,(return-address new-url) (URL ,(return-address new-url)
"Return to main page leaving profile state untouched.") "Return to main page leaving files and state untouched.")
(br) (br)
(URL ,(reset-return-address new-url) (URL ,(reset-return-address new-url)
"Return to main page reseting profile-state")))))) "Return to main page removing files and reseting state."))))))
(bindings (get-bindings req))) (bindings (get-bindings req)))
(cond (cond
((returned-via? new-profile-address bindings) ((returned-via? new-profile-address bindings)
(new-profile req)) (new-profile req))
((returned-via? result-address bindings) ((returned-via? result-address bindings)
(result req)) (if (zero? counter)
(profile req "Now profiles created, currently. Select 'Create new profile' to create one.")
(result req)))
((returned-via? reset-address bindings) ((returned-via? reset-address bindings)
(reset req)) (reset req))
((returned-via? return-address bindings) ((returned-via? return-address bindings)
@ -78,17 +85,20 @@
(profile req "Please enter a file name of an existing executable."))))))) (profile req "Please enter a file name of an existing executable.")))))))
(define (new-profile req) (define (new-profile req)
(format #t "profiling...~%")
(profile-space file-name) (profile-space file-name)
(format #t "profile recorded in ~s~%" file-name)
(set! counter (+ 1 counter)) (set! counter (+ 1 counter))
(profile req (format #f "Profile #~a generated" counter))) (profile req (format #f "Profile #~a generated" counter)))
(define (result req) (define (result req)
(let ((results (profile-results file-name)) (let ((results (profile-results file-name))
(gnuplot-data-file-name (create-temp-file "servlet-profiling.data")) (gnuplot-data-file-name (create-temp-file "servlet-profiling.data"))
(picture-file (create-temp-file "servlet-profiling.picture"))) (picture-file (create-temp-file "servlet-profiling.picture"))
(get-total-bytes (lambda (space-info)
(total-bytes (space-info-total space-info)))))
(write-gnuplot-data-file gnuplot-data-file-name (write-gnuplot-data-file gnuplot-data-file-name
(lambda (space-info) get-total-bytes
(total-bytes (space-info-total space-info)))
results) results)
(let ((status (let ((status
(run (,gnuplot -) (run (,gnuplot -)
@ -106,36 +116,48 @@ plot '~a' title 'Servlet Profiling ~a' with lines"
(title "Servlet Administration -- Profiling Results") (title "Servlet Administration -- Profiling Results")
(body (body
(h1 "Servlet-Administration") (h1 "Servlet-Administration")
(h2 "Profiling") (h2 "Profiling Results")
(h3 "Results") (h3 "Picture")
(p "This is the result of the profilings:")
,(if (zero? status) ,(if (zero? status)
`(image (@ (src ,picture-file))) `(image (@ (src ,picture-file)))
`(p "An error occured while generating the profiling results picture." `(p "An error occured while generating the profiling results picture."
(br) (br)
"Are you sure, you have " (pre "gnuplot") "Are you sure, you have " (q "gnuplot")
" installed at " (pre ,gnuplot) "?")))))))) " installed at " (q ,gnuplot) "?"))
(hr)
(h3 "Data")
(table
(tr (th "#") (th "Total bytes occupied"))
,@(map (lambda (num space-info)
`(tr (td ,(+ 1 num))
(td ,(get-total-bytes space-info))))
(iota (length results))
results))))))))
(define (reset req) (define (reset req)
(reset-profiling-state!) (reset-profiling-state!)
(profile req "Profiling state reseted.")) (profile req "Profiling state reseted."))
(define (delete-files)
(for-each delete-filesys-object file-names-to-delete))
(define (reset-profiling-state!) (define (reset-profiling-state!)
(set! counter 0) (set! counter 0)
(for-each delete-filesys-object file-names-to-delete) (delete-files)
(delete-filesys-object file-name) (set! file-name (absolute-file-name (create-temp-file "servlet-profiling")))
(set! file-name (create-temp-file "servlet-profiling")) (set! file-names-to-delete (list file-name)))
(set! file-names-to-delete '()))
(define (reset-and-return-to-main-page req) (define (reset-and-return-to-main-page req)
(reset-profiling-state!) (reset-profiling-state!)
(return-to-main-page req)) (delete-files)
(return-to-main-page req))
(define (return-to-main-page req) (define (return-to-main-page req)
(send/finish (make-http-error-response http-status/moved-perm req (send/finish (make-http-error-response http-status/moved-perm req
"admin.scm" "admin.scm"))) "admin.scm" "admin.scm")))
(define (main req) (define (main req)
(reset-profiling-state!)
(profile req)) (profile req))
)) ))