sunet/scheme/httpd/surflets/addresses.scm

49 lines
1.4 KiB
Scheme

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; return address
;; generates an unique return-addres
;; may be used like
;; (let ((address (make-address)))
;; (send-html/suspend
;; (lambda (new-url)
;; ...
;; (url (address new-url) "Click here to get more")...)
(define-record-type address :address
(really-make-address name annotated?)
(name real-address-name)
(annotated? real-address-annotated?))
(define (make-address)
(let ((address (really-make-address
(generate-unique-name "return") #f)))
(lambda (message)
(cond
((string? message)
(string-append message "?" (real-address-name address) "="))
((eq? message 'address)
address)
(else
(error "address: unknown message/bad argument"
message (real-address-name address)))))))
(define (make-annotated-address)
(let ((address (really-make-address
(generate-unique-name "return")
#t)))
(lambda (message . annotation)
(cond
((and (string? message)
(<= (length annotation) 1))
(let ((escaped-annotation
(if (null? annotation)
""
(escape-uri (car annotation)))))
(string-append message "?" (real-address-name address)
"=" escaped-annotation)))
((eq? message 'address)
address)
(else
(error "annotated-address: unknown message/bad argument(s)"
message (real-address-name address)))))))