+ Add annotated callbacks.

Callbacks may now be annotated with arbitrary arguments with which the
function will be called. See surflets/test.scm for a (non-didactic) example.

* The extended callbacks justify an extra structure for callbacks:
surflets/callbacks

- make-callback was moved from surflets/utilities to surflets/callbacks
This commit is contained in:
interp 2003-04-14 08:30:27 +00:00
parent c3e7abbdeb
commit c48f952cc5
5 changed files with 64 additions and 16 deletions

View File

@ -63,3 +63,6 @@
(else (else
(error "annotated-address: unknown message/bad argument(s)" (error "annotated-address: unknown message/bad argument(s)"
message (address-name address))))))) message (address-name address)))))))

View File

@ -0,0 +1,25 @@
;; Copyright 2002, 2003 Andreas Bernauer
(define (make-callback function)
(call-with-current-continuation
(lambda (exit)
(let* ((req (send/suspend (lambda (new-url)
(exit new-url)))))
(function req)))))
(define (make-annotated-callback function)
(let* ((annotated-address (make-annotated-address))
(dispatch
(lambda (req)
(let ((bindings (get-bindings req)))
(cond
((returned-via annotated-address bindings) =>
(lambda (args)
(apply function (cons req args))))
(else
(error "annotated-callback:
unexpected return values from website"))))))
(callback (make-callback dispatch)))
(lambda args
(annotated-address callback args))))

View File

@ -307,7 +307,6 @@
(define-interface surflets/utilities-interface (define-interface surflets/utilities-interface
(export form-query-list (export form-query-list
rev-append rev-append
make-callback
generate-unique-name)) generate-unique-name))
;; Intelligent Addresses ;; Intelligent Addresses
@ -319,6 +318,10 @@
; address-add-annotation! ; address-add-annotation!
address-annotation)) address-annotation))
(define-interface surflets/callbacks-interface
(export make-callback
make-annotated-callback))
;; Returned-via (dispatcher for input-fields and intelligent ;; Returned-via (dispatcher for input-fields and intelligent
;; addresses) ;; addresses)
(define-interface surflets/returned-via-interface (define-interface surflets/returned-via-interface
@ -401,7 +404,6 @@
threads ;SLEEP threads ;SLEEP
uri ;URI-PATH-LIST->PATH uri ;URI-PATH-LIST->PATH
with-locks ;WITH-LOCK with-locks ;WITH-LOCK
; inspect-exception ;WITH-INSPECTING-HANDLER
) )
(files surflet-handler)) (files surflet-handler))
@ -551,8 +553,7 @@
;; Some utilities ;; Some utilities
(define-structure surflets/utilities surflets/utilities-interface (define-structure surflets/utilities surflets/utilities-interface
(open scheme (open scheme
parse-html-forms parse-html-forms)
(subset surflet-handler/primitives (send/suspend)))
(files utilities)) (files utilities))
@ -563,8 +564,17 @@
(subset uri (escape-uri)) (subset uri (escape-uri))
define-record-types define-record-types
(subset surflets/utilities (generate-unique-name))) (subset surflets/utilities (generate-unique-name)))
)
(files addresses)) (files addresses))
(define-structure surflets/callbacks surflets/callbacks-interface
(open scheme
srfi-23 ;error
surflets/addresses
(subset surflet-handler/primitives (send/suspend))
surflets/bindings
surflets/returned-via)
(files callbacks))
(define-structure surflets/returned-via surflets/returned-via-interface (define-structure surflets/returned-via surflets/returned-via-interface
(open scheme (open scheme

View File

@ -20,13 +20,6 @@
(rev-app (cdr a) (cons (car a) b)) (rev-app (cdr a) (cons (car a) b))
b))) b)))
(define (make-callback function)
(call-with-current-continuation
(lambda (exit)
(let* ((req (send/suspend (lambda (new-url)
(exit new-url)))))
(function req)))))
;; FIXME: consider creating small names ;; FIXME: consider creating small names
(define generate-unique-name (define generate-unique-name
(let ((id 0)) (let ((id 0))

View File

@ -1,23 +1,40 @@
(define-structure surflet surflet-interface (define-structure surflet surflet-interface
(open scheme-with-scsh (open scheme-with-scsh
surflets surflets
surflets/utilities
surflets/callbacks
httpd-responses) httpd-responses)
(begin (begin
(define global '()) (define global '())
(define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2)))) (define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2))))
(define (result req arg)
(send-html
`(html (title "Result")
(body (h2 "Result")
(p "Returned via callback with arg" (br)
,(format #f "~s" arg))))))
(define (main req) (define (main req)
(set! global (cons 1 global)) (set! global (cons 1 global))
(let* ((addr (make-annotated-address)) (let* ((an-cb (make-annotated-callback result))
(addr (make-annotated-address))
(req (send-html/suspend (req (send-html/suspend
(lambda (new-url) (lambda (new-url)
`(html (body (h1 "This is from SUrflet") `(html (body (h1 "This is from SUrflet")
(p "called " ,(length global) " times") (p "called " ,(length global) " times")
(url ,(addr new-url "ab=ba")) (br) (p "Choose an annotated address:" (br)
(url ,(addr new-url "be<ta")) (br) (ul
(url ,(addr new-url)) (br) (li (url ,(addr new-url "ab=ba") "ab=ba"))
(abba) (li (url ,(addr new-url "be<ta") "be<ta"))
(li (url ,(addr new-url) "<nothing>"))))
(p "Or choose an annotated callback" (br)
(ul
(li (url ,(an-cb 13) "13"))
(li (url ,(an-cb '(1 2 3)) "'(1 2 3)"))
(li (url ,(an-cb "hello") "hello"))
(li (url ,(an-cb #f) "#f"))))
(surflet-form (surflet-form
,new-url ,new-url
POST POST