utilities for servlet plugins on higher level
This commit is contained in:
parent
9328d1fa82
commit
0b2a59b6ef
|
@ -146,7 +146,10 @@ You can try starting at the <A HREF=~a>beginning</a>."
|
|||
|
||||
(define (send/finish response)
|
||||
(instance-delete! (session-instance-id))
|
||||
response)
|
||||
(shift unused response))
|
||||
|
||||
(define (send response)
|
||||
(shift unsused response))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; access to instance-table
|
||||
|
|
|
@ -0,0 +1,61 @@
|
|||
;; utilities for plugin (servlets)
|
||||
;; Copyright 2002, Andreas Bernauer
|
||||
|
||||
(define (send-html/suspend html-tree-maker)
|
||||
(send/suspend
|
||||
(lambda (new-url)
|
||||
(make-usual-html-response
|
||||
(lambda (out options)
|
||||
(with-current-output-port* ; FIXME: will change in further revision
|
||||
out
|
||||
(lambda () (SXML->HTML (html-tree-maker new-url)))))))))
|
||||
|
||||
(define (send-html/finish html-tree)
|
||||
(do-sending send/finish html-tree))
|
||||
|
||||
(define (send-html html-tree)
|
||||
(do-sending send html-tree))
|
||||
|
||||
(define (do-sending sending-version html-tree)
|
||||
(sending-version
|
||||
(make-usual-html-response
|
||||
(lambda (out options)
|
||||
(with-current-output-port* ; FIXME: will change in further revision
|
||||
out
|
||||
(lambda () (SXML->HTML html-tree)))))))
|
||||
(
|
||||
|
||||
(define (make-usual-html-response writer-proc)
|
||||
(make-response
|
||||
http-status/ok
|
||||
(status-code->text http-status/ok)
|
||||
(time)
|
||||
"text/html"
|
||||
'()
|
||||
(make-writer-body writer-proc)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; from cgi-script:
|
||||
;;; Return the form data as an alist of decoded strings.
|
||||
;;; So a query string like "button=on&reply=Oh,%20yes" becomes alist
|
||||
;;; (("button" . "on") ("reply" . "Oh, yes"))
|
||||
;;; This only works for GET and POST methods.
|
||||
|
||||
(define form-query parse-html-form-query)
|
||||
|
||||
(define (extract-bindings bindings key)
|
||||
(let ((key (if (symbol? key) (symbol->string key) key)))
|
||||
(filter (lambda (binding)
|
||||
(equal? (car binding) key))
|
||||
bindings)))
|
||||
|
||||
(define (extract-single-binding bindings key)
|
||||
(let ((key-bindings (extract-bindings bindings key)))
|
||||
(if (= 1 (length key-bindings))
|
||||
(cdar key-bindings)
|
||||
(error "extract-one-binding: more than one or zero bindings found"
|
||||
(length key-bindings)
|
||||
key bindings))))
|
||||
|
||||
|
||||
|
|
@ -8,6 +8,8 @@
|
|||
Following files are available from here:
|
||||
<ul>
|
||||
<li><a href=/servlet/news.scm>News</a></li>
|
||||
<li><a href=/servlet/add.scm>Adding (Version 1)</a></li>
|
||||
<li><a href="servlet/add2.scm">Adding (version 2)</a></li>
|
||||
<li><a href=/servlet/test.scm>A test servlet</a></li>
|
||||
<li><a href=index.html>This file</a></li>
|
||||
</ul>
|
||||
|
@ -17,7 +19,7 @@
|
|||
<hr>
|
||||
<!-- Created: Thu Aug 22 16:44:16 CEST 2002 -->
|
||||
<!-- hhmts start -->
|
||||
Last modified: Thu Sep 19 13:58:31 CEST 2002
|
||||
Last modified: Tue Sep 24 10:16:52 CEST 2002
|
||||
<!-- hhmts end -->
|
||||
</body>
|
||||
</html>
|
||||
|
|
Loading…
Reference in New Issue