49 lines
1.4 KiB
Scheme
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)))))))
|