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)
 | 
					(define (send/finish response)
 | 
				
			||||||
  (instance-delete! (session-instance-id))
 | 
					  (instance-delete! (session-instance-id))
 | 
				
			||||||
  response)
 | 
					  (shift unused response))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					(define (send response)
 | 
				
			||||||
 | 
					  (shift unsused response))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 | 
					;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 | 
				
			||||||
;; access to instance-table
 | 
					;; 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:
 | 
					    Following files are available from here:
 | 
				
			||||||
    <ul>
 | 
					    <ul>
 | 
				
			||||||
      <li><a href=/servlet/news.scm>News</a></li>
 | 
					      <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=/servlet/test.scm>A test servlet</a></li>
 | 
				
			||||||
      <li><a href=index.html>This file</a></li>
 | 
					      <li><a href=index.html>This file</a></li>
 | 
				
			||||||
    </ul>
 | 
					    </ul>
 | 
				
			||||||
| 
						 | 
					@ -17,7 +19,7 @@
 | 
				
			||||||
    <hr>
 | 
					    <hr>
 | 
				
			||||||
    <!-- Created: Thu Aug 22 16:44:16 CEST 2002 -->
 | 
					    <!-- Created: Thu Aug 22 16:44:16 CEST 2002 -->
 | 
				
			||||||
    <!-- hhmts start -->
 | 
					    <!-- hhmts start -->
 | 
				
			||||||
Last modified: Thu Sep 19 13:58:31 CEST 2002
 | 
					Last modified: Tue Sep 24 10:16:52 CEST 2002
 | 
				
			||||||
<!-- hhmts end -->
 | 
					<!-- hhmts end -->
 | 
				
			||||||
  </body>
 | 
					  </body>
 | 
				
			||||||
</html>
 | 
					</html>
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
		Reference in New Issue