Index: cookie.scm
==================================================================
--- cookie.scm
+++ cookie.scm
@@ -42,211 +42,216 @@
 ;; The parser also supports the old Netscape spec
 ;;   <http://www.netscape.com/newsref/std/cookie_spec.html>
 
 (declare (unit cookie))
 (require-extension srfi-1 srfi-13 srfi-14 regex)
-(declare (export parse-cookie-string construct-cookie-string))
-
-#>
-#include <time.h>
-<#
-
-(define fmt-time
-  (foreign-lambda* c-string ((long secs_since_epoch))
-    "static char buf[256];"
-    "time_t t = (time_t) secs_since_epoch;"
-    "strftime(buf, sizeof(buf), \"%a, %d-%b-%Y %H:%M:%S GMT\", gmtime(&t));"
-    "return(buf);"))
-
-;; utility fn.  breaks  ``attr=value;attr=value ... '' into alist.
-;; version is a cookie version.  if version>0, we allow comma as the
-;; delimiter as well as semicolon.
-(define (parse-av-pairs input version)
-  (define attr-regexp
-    (if (= version 0)
-        (regexp "\\s*([\\w$_-]+)\\s*([=\\;]\\s*)?")
-        (regexp "\\s*([\\w$_-]+)\\s*([=\\;,]\\s*)?")))
-  (define attr-delim
-    (if (= version 0) #\; (char-set #\, #\\ #\;)))
-  
-  (define (read-attr input r)
-    (cond ((string-null? input) (reverse! r))
-          ((string-search attr-regexp input)
-           => (lambda (m)
-                (if (and-let* ((delimiter (third m))) ;;is an attr_value pai
-		      (string-prefix? "=" delimiter))
-                    (let ((attr (second m))
-                          (rest (string-search-after attr-regexp input)))
-                      (if (string-prefix? "\"" rest)
-                          (read-token-quoted attr (string-drop rest 1) r)
-                          (read-token attr rest r)))
-                    (read-attr (string-search-after attr-regexp input) ;; Skip ahead if broken input?
-                               (alist-cons (second m) #f r)))))
-          (else
-           ;; the input is broken; for now, we ignore the rest.
-           (reverse! r))))
-  (define (read-token attr input r)
-    (cond ((string-index input attr-delim)
-           => (lambda (i)
-                (read-attr (string-drop input (+ i 1))
-                           (alist-cons attr
-				       (string-trim-right (string-take input i))
-				       r))))
-          (else
-           (reverse! (alist-cons attr (string-trim-right input) r)))))
-  (define (read-token-quoted attr input r)
-    (let loop ((input input)
-               (partial '()))
-      (cond ((string-index input (char-set #\\ #\"))
-             => (lambda (i)
-                  (let ((c (string-ref input i)))
-                    (if (char=? c #\\)
-                        (if (< (string-length input) (+ i 1))
-                            (error-unterminated attr)
-                            (loop (string-drop input (+ i 2))
-                                  (cons* (string (string-ref input (+ i 1)))
-                                         (string-take input i)
-                                         partial)))
-                        (read-attr (string-drop input (+ i 1))
-                                   (alist-cons attr
-					       (string-concatenate-reverse
-						(cons (string-take input i)
-						      partial))
-					       r))))))
-            (else (error-unterminated attr)))))
-  (define (error-unterminated attr)
-    (error "Unterminated quoted value given for attribute" attr))
-
-  (read-attr input '()))
-
-;; Parses the header value of "Cookie" request header.
-;; If cookie version is known by "Cookie2" request header, it should
-;; be passed to version (as integer).  Otherwise, it figures out
-;; the cookie version from input.
-;;
-;; Returns the following format.
-;;   ((<name> <value> [:path <path>] [:domain <domain>] [:port <port>])
-;;    ...)
-
-(define (parse-cookie-string input #!optional version)
-  (let ((ver (cond ((integer? version) version)
-                   ((string-search "^\\s*\\$Version\\s*=\\s*(\\d+)" input)
-                    => (lambda (m)
-                         (string->number (cadr m))))
-                   (else 0))))
-    (let loop ((av-pairs (parse-av-pairs input ver))
-               (r '())
-               (current '()))
-      (cond ((null? av-pairs)
-             (if (null? current)
-                 (reverse r)
-                 (reverse (cons (reverse current) r))))
-            ((string-ci=? "$path" (caar av-pairs))
-             (loop (cdr av-pairs) r (cons* (cdar av-pairs) path: current)))
-            ((string-ci=? "$domain" (caar av-pairs))
-             (loop (cdr av-pairs) r (cons* (cdar av-pairs) domain: current)))
-            ((string-ci=? "$port" (caar av-pairs))
-             (loop (cdr av-pairs) r (cons* (cdar av-pairs) port: current)))
-            (else
-             (if (null? current)
-                 (loop (cdr av-pairs) r (list (cdar av-pairs) (caar av-pairs)))
-                 (loop (cdr av-pairs)
-                       (cons (reverse current) r)
-                       (list (cdar av-pairs) (caar av-pairs)))))))))
-
-;; Construct a cookie string suitable for Set-Cookie or Set-Cookie2 header.
-;; specs is the following format.
-;;
-;;   ((<name> <value> [:comment <comment>] [:comment-url <comment-url>]
-;;                    [:discard <bool>] [:domain <domain>]
-;;                    [:max-age <age>] [:path <value>] [:port <port-list>]
-;;                    [:secure <bool>] [:version <version>] [:expires <date>]
-;;    ) ...)
-;;
-;; Returns a list of cookie strings for each <name>=<value> pair.  In the
-;; ``new cookie'' implementation, you can join them by comma and send it
-;; at once with Set-cookie2 header.  For the old netscape protocol, you
-;; must send each of them by Set-cookie header.
-
-
-(define (construct-cookie-string specs #!optional (version 1))
-  (map (lambda (spec) (construct-cookie-string-1 spec version))
-       specs))
-
-(define (construct-cookie-string-1 spec ver)
-  (when (< (length spec) 2)
-    (error "bad cookie spec: at least <name> and <value> required" spec))
-  (let ((name (car spec))
-        (value (cadr spec)))
-    (let loop ((attr (cddr spec))
-               (r    (list (if value
-                               (string-append name "="
-                                              (quote-if-needed value))
-                               name))))
-      (define (next s) (loop (cddr attr) (cons s r)))
-      (define (ignore) (loop (cddr attr) r))
-      (cond
-       ((null? attr) (string-join (reverse r) ";"))
-       ((null? (cdr attr))
-        (error (conc "bad cookie spec: attribute " (car attr) " requires value" )))
-       ((eqv? comment: (car attr))
-        (if (> ver 0)
-	    (next (string-append "Comment=" (quote-if-needed (cadr attr))))
-            (ignore)))
-       ((eqv? comment-url: (car attr))
-        (if (> ver 0)
-            (next (string-append "CommentURL=" (quote-value (cadr attr))))
-            (ignore)))
-       ((eqv? discard: (car attr))
-        (if (and (> ver 0) (cadr attr)) (next "Discard") (ignore)))
-       ((eqv? domain: (car attr))
-        (next (string-append "Domain=" (cadr attr))))
-       ((eqv? max-age: (car attr))
-        (if (> ver 0)
-            (next (sprintf "Max-Age=~a" (cadr attr)))
-            (ignore)))
-       ((eqv? path: (car attr))
-        (next (string-append "Path=" (quote-if-needed (cadr attr)))))
-       ((eqv? port: (car attr))
-        (if (> ver 0)
-            (next (string-append "Port=" (quote-value (cadr attr))))
-            (ignore)))
-       ((eqv? secure: (car attr))
-        (if (cadr attr) (next "Secure") (ignore)))
-       ((eqv? version: (car attr))
-        (if (> ver 0)
-            (next (sprintf "Version=~a" (cadr attr)))
-            (ignore)))
-       ((eqv? expires: (car attr))
-        (if (> ver 0)
-            (ignore)
-            (next (make-expires-attr (cadr attr)))))
-       (else (error "Unknown cookie attribute" (car attr))))
-      ))
-  )
-
-
-;; (define (quote-value value)
-;;   (string-append "\"" (regexp-replace-all #/\"|\\/ value "\\\\\\0") "\""))
-
-(define (quote-value value)
-  (string-append "\"" (string-substitute* value '(("\\\"" . "\\\"") ("\\\\" . "\\\\"))) "\""))
-
-(define quote-if-needed
-  (let ((rx (regexp "[\\\",;\\\\ \\t\\n]")))
-    (lambda (value)
-      (if (string-search rx value)
-	  (quote-value value)
-	  value))))
-
-(define (make-expires-attr time)
-  (sprintf "Expires=~a"
-	   (if (number? time)
-	       (fmt-time time)
-	       time)))
-
-;;;; Added support functions from my utils, split this out
-
-(define (string-search-after r s #!optional (start 0))
-  (and-let* ((match-indices (string-search-positions r s start))
-	     (right-match (second (first match-indices))))
-    (substring s right-match)))
+;; (use  srfi-1 srfi-13 srfi-14 regex)
+;; (declare (export parse-cookie-string construct-cookie-string))
+
+;;  #>
+;;  #include <time.h>
+;;  <#
+;;  
+;;  (define fmt-time
+;;    (foreign-lambda* c-string ((long secs_since_epoch))
+;;      "static char buf[256];"
+;;      "time_t t = (time_t) secs_since_epoch;"
+;;      "strftime(buf, sizeof(buf), \"%a, %d-%b-%Y %H:%M:%S GMT\", gmtime(&t));"
+;;      "return(buf);"))
+;;  
+
+(define (fmt-time seconds)
+  (time->string (seconds->utc-time seconds) "%D"))
+
+ ;; utility fn.  breaks  ``attr=value;attr=value ... '' into alist.
+ ;; version is a cookie version.  if version>0, we allow comma as the
+ ;; delimiter as well as semicolon.
+ (define (parse-av-pairs input version)
+   (define attr-regexp
+     (if (= version 0)
+         (regexp "\\s*([\\w$_-]+)\\s*([=\\;]\\s*)?")
+         (regexp "\\s*([\\w$_-]+)\\s*([=\\;,]\\s*)?")))
+   (define attr-delim
+     (if (= version 0) #\; (char-set #\, #\\ #\;)))
+   
+   (define (read-attr input r)
+     (cond ((string-null? input) (reverse! r))
+           ((string-search attr-regexp input)
+            => (lambda (m)
+                 (if (and-let* ((delimiter (third m))) ;;is an attr_value pai
+ 		      (string-prefix? "=" delimiter))
+                     (let ((attr (second m))
+                           (rest (string-search-after attr-regexp input)))
+                       (if (string-prefix? "\"" rest)
+                           (read-token-quoted attr (string-drop rest 1) r)
+                           (read-token attr rest r)))
+                     (read-attr (string-search-after attr-regexp input) ;; Skip ahead if broken input?
+                                (alist-cons (second m) #f r)))))
+           (else
+            ;; the input is broken; for now, we ignore the rest.
+            (reverse! r))))
+   (define (read-token attr input r)
+     (cond ((string-index input attr-delim)
+            => (lambda (i)
+                 (read-attr (string-drop input (+ i 1))
+                            (alist-cons attr
+ 				       (string-trim-right (string-take input i))
+ 				       r))))
+           (else
+            (reverse! (alist-cons attr (string-trim-right input) r)))))
+   (define (read-token-quoted attr input r)
+     (let loop ((input input)
+                (partial '()))
+       (cond ((string-index input (char-set #\\ #\"))
+              => (lambda (i)
+                   (let ((c (string-ref input i)))
+                     (if (char=? c #\\)
+                         (if (< (string-length input) (+ i 1))
+                             (error-unterminated attr)
+                             (loop (string-drop input (+ i 2))
+                                   (cons* (string (string-ref input (+ i 1)))
+                                          (string-take input i)
+                                          partial)))
+                         (read-attr (string-drop input (+ i 1))
+                                    (alist-cons attr
+ 					       (string-concatenate-reverse
+ 						(cons (string-take input i)
+ 						      partial))
+ 					       r))))))
+             (else (error-unterminated attr)))))
+   (define (error-unterminated attr)
+     (error "Unterminated quoted value given for attribute" attr))
+ 
+   (read-attr input '()))
+ 
+ ;; Parses the header value of "Cookie" request header.
+ ;; If cookie version is known by "Cookie2" request header, it should
+ ;; be passed to version (as integer).  Otherwise, it figures out
+ ;; the cookie version from input.
+ ;;
+ ;; Returns the following format.
+ ;;   ((<name> <value> [:path <path>] [:domain <domain>] [:port <port>])
+ ;;    ...)
+ 
+ (define (parse-cookie-string input #!optional version)
+   (let ((ver (cond ((integer? version) version)
+                    ((string-search "^\\s*\\$Version\\s*=\\s*(\\d+)" input)
+                     => (lambda (m)
+                          (string->number (cadr m))))
+                    (else 0))))
+     (let loop ((av-pairs (parse-av-pairs input ver))
+                (r '())
+                (current '()))
+       (cond ((null? av-pairs)
+              (if (null? current)
+                  (reverse r)
+                  (reverse (cons (reverse current) r))))
+             ((string-ci=? "$path" (caar av-pairs))
+              (loop (cdr av-pairs) r (cons* (cdar av-pairs) path: current)))
+             ((string-ci=? "$domain" (caar av-pairs))
+              (loop (cdr av-pairs) r (cons* (cdar av-pairs) domain: current)))
+             ((string-ci=? "$port" (caar av-pairs))
+              (loop (cdr av-pairs) r (cons* (cdar av-pairs) port: current)))
+             (else
+              (if (null? current)
+                  (loop (cdr av-pairs) r (list (cdar av-pairs) (caar av-pairs)))
+                  (loop (cdr av-pairs)
+                        (cons (reverse current) r)
+                        (list (cdar av-pairs) (caar av-pairs)))))))))
+ 
+ ;; Construct a cookie string suitable for Set-Cookie or Set-Cookie2 header.
+ ;; specs is the following format.
+ ;;
+ ;;   ((<name> <value> [:comment <comment>] [:comment-url <comment-url>]
+ ;;                    [:discard <bool>] [:domain <domain>]
+ ;;                    [:max-age <age>] [:path <value>] [:port <port-list>]
+ ;;                    [:secure <bool>] [:version <version>] [:expires <date>]
+ ;;    ) ...)
+ ;;
+ ;; Returns a list of cookie strings for each <name>=<value> pair.  In the
+ ;; ``new cookie'' implementation, you can join them by comma and send it
+ ;; at once with Set-cookie2 header.  For the old netscape protocol, you
+ ;; must send each of them by Set-cookie header.
+ 
+ 
+ (define (construct-cookie-string specs #!optional (version 1))
+   (map (lambda (spec) (construct-cookie-string-1 spec version))
+        specs))
+ 
+ (define (construct-cookie-string-1 spec ver)
+   (when (< (length spec) 2)
+     (error "bad cookie spec: at least <name> and <value> required" spec))
+   (let ((name (car spec))
+         (value (cadr spec)))
+     (let loop ((attr (cddr spec))
+                (r    (list (if value
+                                (string-append name "="
+                                               (quote-if-needed value))
+                                name))))
+       (define (next s) (loop (cddr attr) (cons s r)))
+       (define (ignore) (loop (cddr attr) r))
+       (cond
+        ((null? attr) (string-join (reverse r) ";"))
+        ((null? (cdr attr))
+         (error (conc "bad cookie spec: attribute " (car attr) " requires value" )))
+        ((eqv? comment: (car attr))
+         (if (> ver 0)
+ 	    (next (string-append "Comment=" (quote-if-needed (cadr attr))))
+             (ignore)))
+        ((eqv? comment-url: (car attr))
+         (if (> ver 0)
+             (next (string-append "CommentURL=" (quote-value (cadr attr))))
+             (ignore)))
+        ((eqv? discard: (car attr))
+         (if (and (> ver 0) (cadr attr)) (next "Discard") (ignore)))
+        ((eqv? domain: (car attr))
+         (next (string-append "Domain=" (cadr attr))))
+        ((eqv? max-age: (car attr))
+         (if (> ver 0)
+             (next (sprintf "Max-Age=~a" (cadr attr)))
+             (ignore)))
+        ((eqv? path: (car attr))
+         (next (string-append "Path=" (quote-if-needed (cadr attr)))))
+        ((eqv? port: (car attr))
+         (if (> ver 0)
+             (next (string-append "Port=" (quote-value (cadr attr))))
+             (ignore)))
+        ((eqv? secure: (car attr))
+         (if (cadr attr) (next "Secure") (ignore)))
+        ((eqv? version: (car attr))
+         (if (> ver 0)
+             (next (sprintf "Version=~a" (cadr attr)))
+             (ignore)))
+        ((eqv? expires: (car attr))
+         (if (> ver 0)
+             (ignore)
+             (next (make-expires-attr (cadr attr)))))
+        (else (error "Unknown cookie attribute" (car attr))))
+       ))
+   )
+ 
+ 
+ ;; (define (quote-value value)
+ ;;   (string-append "\"" (regexp-replace-all #/\"|\\/ value "\\\\\\0") "\""))
+ 
+ (define (quote-value value)
+   (string-append "\"" (string-substitute* value '(("\\\"" . "\\\"") ("\\\\" . "\\\\"))) "\""))
+ 
+ (define quote-if-needed
+   (let ((rx (regexp "[\\\",;\\\\ \\t\\n]")))
+     (lambda (value)
+       (if (string-search rx value)
+ 	  (quote-value value)
+ 	  value))))
+ 
+ (define (make-expires-attr time)
+   (sprintf "Expires=~a"
+ 	   (if (number? time)
+ 	       (fmt-time time)
+ 	       time)))
+ 
+ ;;;; Added support functions from my utils, split this out
+ 
+ (define (string-search-after r s #!optional (start 0))
+   (and-let* ((match-indices (string-search-positions r s start))
+ 	     (right-match (second (first match-indices))))
+     (substring s right-match)))

Index: tests/test.scm
==================================================================
--- tests/test.scm
+++ tests/test.scm
@@ -15,11 +15,11 @@
 (import (prefix sqlite3 sqlite3:))
 
 (require-library dbi)
 
 (load "./requirements.scm")
-(load "./cookie.so")
+(load "./cookie.scm")
 (load "./misc-stml.scm")
 (load "./formdat.scm")
 (load "./stml.scm")
 (load "./session.scm")
 (load "./sqltbl.scm")