Add MAKE-ANNOTATED-ADDRESS that creates string-annotated return-addresses

This commit is contained in:
interp 2003-02-28 08:22:29 +00:00
parent b2884b22e2
commit 98f0da38c6
2 changed files with 44 additions and 11 deletions

View File

@ -185,6 +185,7 @@
input-field-binding
make-address
make-annotated-address
returned-via?
make-callback
@ -197,6 +198,7 @@
httpd-responses ; STATUS-CODE
surflet-requests ; HTTP-URL:SEARCH
url ; REQUEST:URL
(subset uri (escape-uri unescape-uri))
parse-html-forms
sxml-to-html ; SXML->HTML
srfi-1 ; FILTER

View File

@ -246,8 +246,6 @@
(function req)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; outdater
@ -633,22 +631,55 @@
;; (lambda (new-url)
;; ...
;; (URL (address new-url) "Click here to get more")...)
(define-record-type address :address
(really-make-address name annotated?)
(name address-name)
(annotated? address-annotated?))
(define (make-address)
(let ((name (generate-unique-name "return")))
(let ((address (really-make-address
(generate-unique-name "return") #f)))
(lambda (message)
(cond
((string? message)
(string-append message "?" name "="))
((eq? message 'name)
name)
(else ;maybe we want more later...
(error "unknown message" message name))))))
(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 ((escaped-annotation
(if (null? annotation)
""
(escape-uri (car annotation)))))
(string-append message "?" (address-name address)
"=" escaped-annotation)))
((eq? message 'address)
address)
(else
(error "annotated-address: unknown message/bad argument(s)"
message (address-name address)))))))
(define (returned-via? return-object bindings)
(format #t "returned-via? ~a~%" return-object)
(if (input-field? return-object)
(input-field-binding return-object bindings)
;; We assume we have a return-address-object instead.
(assoc (return-object 'name) bindings)))
(let ((address (return-object 'address)))
(cond
((assoc (address-name address) bindings) =>
(lambda (pair)
(if (address-annotated? address)
(unescape-uri (cdr pair))
#t)))
(else #f)))))