From bd613946d06a351bfbf2a73d55bfb4abbe825eba Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Mon, 3 Mar 2003 10:27:49 +0000
Subject: [PATCH] + CASE-RETURNED-VIA from mainzelm added + RETURNED-VIA alias
 for RETURNED-VIA? added

---
 scheme/httpd/surflets/packages.scm |  2 ++
 scheme/httpd/surflets/surflets.scm | 27 +++++++++++++++++++++++++--
 2 files changed, 27 insertions(+), 2 deletions(-)

diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm
index 989af68..04c647a 100644
--- a/scheme/httpd/surflets/packages.scm
+++ b/scheme/httpd/surflets/packages.scm
@@ -186,7 +186,9 @@
 
 	  make-address
 	  make-annotated-address
+	  returned-via
 	  returned-via?
+	  (case-returned-via :syntax)
 	  make-callback
 
 	  set-surflet-data!
diff --git a/scheme/httpd/surflets/surflets.scm b/scheme/httpd/surflets/surflets.scm
index 76fa7b7..6861da9 100644
--- a/scheme/httpd/surflets/surflets.scm
+++ b/scheme/httpd/surflets/surflets.scm
@@ -1,5 +1,6 @@
 ;; utilities for surflet
-;; Copyright 2002, Andreas Bernauer
+;; Copyright 2002,2003, Andreas Bernauer
+;; Copyright 2003, Martin Gasbichler
 
 (define (send-html/suspend html-tree-maker)
   (send/suspend 
@@ -670,7 +671,7 @@
 	(error "annotated-address: unknown message/bad argument(s)" 
 	       message (address-name address)))))))
 
-(define (returned-via? return-object bindings)
+(define (returned-via return-object bindings)
   (if (input-field? return-object)
       (input-field-binding return-object bindings)
       ;; We assume we have a return-address-object instead.
@@ -683,3 +684,25 @@
 		#t)))
 	 (else #f)))))
 
+;; It depends on the object, if returned-via returns only boolean
+;; values or string values as well. So let us have both names.
+(define returned-via? returned-via)
+
+;; This is from Martin Gasbichler
+(define-syntax case-returned-via
+  (syntax-rules (else)
+    ((case-returned-via (%bindings ...) clauses ...)
+     (let ((bindings (%bindings ...)))
+       (case-returned-via bindings clauses ...)))
+    ((case-returned-via bindings (else body ...))
+     (begin body ...))
+    ((case-returned-via bindings
+                        ((%return-object ...) %body ...))
+     (if (or (returned-via? %return-object bindings) ...)
+         (begin %body ...)))
+    ((case-returned-via bindings
+                        ((%return-object ...) %body ...)
+                        %clause %clauses ...)
+     (if (or (returned-via? %return-object bindings) ...)
+         (begin %body ...) 
+         (case-returned-via bindings %clause %clauses ...)))))