sunet/scheme/httpd/surflets/addresses.scm

69 lines
2.0 KiB
Scheme
Raw Normal View History

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; return address
;; generates an unique return-address
;; 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
(make-address-constructor name annotated? annotations)
(name address-name)
(annotated? address-annotated?)
(annotations address-annotations set-address-annotations!))
(define (really-make-address name annotated?)
(if annotated?
(make-address-constructor name annotated? #f)
(make-address-constructor name annotated? '())))
(define (address-add-annotation! address annotation)
(let ((index (generate-unique-name "val")))
(set-address-annotations! address
(cons (cons index annotation)
(address-annotations address)))
index))
(define (address-annotation address index)
(cond
((assoc index (address-annotations address)) => cdr)
(else #f)))
(define (make-address)
(let ((address (really-make-address
(generate-unique-name "return") #f)))
(lambda (message)
(cond
((string? message)
(string-append message "?" (address-name address) "="))
((eq? message 'address)
address)
(else
(error "address: unknown message/bad argument"
message (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 ((index (if (null? annotation)
(address-add-annotation! address "")
(address-add-annotation! address (car annotation)))))
(string-append message "?" (address-name address)
"=" index)))
((eq? message 'address)
address)
(else
(error "annotated-address: unknown message/bad argument(s)"
message (address-name address)))))))