r5250: *** empty log message ***

[cl-modlisp.git] / demo.lisp

diff --git a/demo.lisp b/demo.lisp
index 87c0aac00a473e58d67ce4d3e6afed2d144e1785..c9e7e0f9125a67e69c4060758a4ee24558af3225 100644 (file)
--- a/demo.lisp
+++ b/demo.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Dec 2002
 ;;;;
-;;;; $Id: demo.lisp,v 1.1 2003/07/05 00:59:49 kevin Exp $
+;;;; $Id: demo.lisp,v 1.2 2003/07/08 06:40:00 kevin Exp $
 ;;;; *************************************************************************
 
 (in-package #:modlisp)
@@ -65,3 +65,38 @@
 
 
     
+;;; A small test bench used to test and time the client/server protocol 
+;;; From Marc Battyani
+
+(defun fetch-mod-lisp-url (server url &key (num-fetch 1) (port 20123)
+                          close-socket)
+  (loop with server-socket and reply
+       repeat num-fetch
+       do (unless server-socket
+            (setf server-socket (make-active-socket server port)))
+          (write-string "url" server-socket)
+           (write-char #\NewLine server-socket)
+          (write-string url server-socket)
+          (write-char #\NewLine server-socket)
+          (write-string "end" server-socket)
+          (write-char #\NewLine server-socket)
+          (force-output server-socket)
+          (setf reply (read-reply server-socket))
+          (when close-socket
+            (close server-socket)
+            (setf server-socket nil))
+          finally
+          (unless close-socket (close server-socket))
+          (return reply)))
+
+(defun read-reply (socket)
+  (let* ((header (loop for key = (read-line socket nil nil)
+                      while (and key (string-not-equal key "end"))
+                      for value = (read-line socket nil nil)
+                      collect (cons key value)))
+        (content-length (cdr (assoc "Content-Length" header :test #'string=)))
+        (content (when content-length (make-string (parse-integer content-length :junk-allowed t)))))
+    (when content
+      (read-sequence content socket)
+      (push (cons "reply-content" content) header))
+    header))