[Lisppaste-cvs] CVS update: lisppaste2/encode-for-pre.lisp

[Brian Mastenbrook]

Update of /project/lisppaste/cvsroot/lisppaste2
In directory common-lisp.net:/home/bmastenbrook/lisppaste2

Modified Files:
	encode-for-pre.lisp 
Log Message:
Thanks much to Xach for a rewrite

Date: Fri May 21 18:11:09 2004
Author: bmastenbrook

Index: lisppaste2/encode-for-pre.lisp
diff -u lisppaste2/encode-for-pre.lisp:1.13 lisppaste2/encode-for-pre.lisp:1.14
--- lisppaste2/encode-for-pre.lisp:1.13	Wed Mar 31 16:33:07 2004
+++ lisppaste2/encode-for-pre.lisp	Fri May 21 18:11:09 2004
@@ -1,53 +1,70 @@
-;;;; $Id: encode-for-pre.lisp,v 1.13 2004/03/31 21:33:07 bmastenbrook Exp $
+;;;; $Id: encode-for-pre.lisp,v 1.14 2004/05/21 22:11:09 bmastenbrook Exp $
 ;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/encode-for-pre.lisp,v $
 
 ;;;; See the LICENSE file for licensing information.
 
 (in-package :lisppaste)
 
-(defun replace-in-string-1 (str char repstr &optional only-in-dup)
-  (let* ((new-length (loop for i from 0 to (1- (length str))
-			   summing (if (not only-in-dup)
-                                       (if (char= (elt str i) char)
-                                           (length repstr) 1)
-                                       (if (> i 0)
-                                           (if (and (member (elt str (1- i)) only-in-dup :test #'char=)
-                                                    (char= (elt str i) char))
-                                               (length repstr) 1) 1))))
-	 (new-array (make-array `(,new-length) :element-type 'character)))
-    (loop for i from 0 to (1- (length str))
-	  with j = 0
-	  do (if (if only-in-dup
-                     (and (> i 0) (char= (elt str i) char)
-			  (member (elt str (1- i))
-				  only-in-dup :test #'char=))
-                     (char= (elt str i) char))
-		 (progn
-		   (loop for k from 0 to (1- (length repstr))
-			 do (setf (elt new-array (+ j k)) (elt repstr k)))
-		   (incf j (length repstr)))
-		 (progn
-		   (setf (elt new-array j) (elt str i))
-		   (incf j))))
-    new-array))
-
-(defun replace-in-string (str chars repstrs)
-  (declare (type string str))
-  (let ((stri str))
-    (loop for char in chars for repstr in repstrs do
-	  (setf stri (replace-in-string-1 stri char repstr)))
-    stri))
-
-(defun encode-for-pre (str)
-  (replace-in-string str '(#\& #\< #\>) '("&" "<" ">")))
-
-(defun replace-first-space (str)
-  (if (char= (elt str 0) #\space)
-      (concatenate 'string " " (subseq str 1))
-    str))
-
-(defun encode-for-tt (str)
-  (replace-first-space (replace-in-string-1 (replace-in-string str '(#\& #\< #\> #\newline #\return #\linefeed #\tab) '("&" "<" ">" "<br>" "" "" "    ")) #\space " " '(#\space #\>))))
-
-(defun encode-for-http (str)
-  (replace-in-string-1 str #\> (format nil ">~%") nil))
+(defun encode-for-tt (string)
+  (let ((pos 0) (end (length string))
+        (char nil))
+    (flet ((next-char ()
+             (setf char (when (> end pos)
+                          (prog1
+                              (schar string pos)
+                            (incf pos))))))
+      (with-output-to-string (out)
+        (block nil
+          (tagbody
+           escape-spaces
+             (next-char)
+             (when (eql char #\Space)
+               (write-string " " out)
+               (go escape-spaces))
+           process-char
+             (case char
+               ((nil) (return))
+               ((#\Newline)
+                (write-string "<br>" out)
+                (go escape-spaces))
+               ((#\&)
+                (write-string "&" out))
+               ((#\<)
+                (write-string "<" out))
+               ((#\>)
+                (write-string ">" out))
+               ((#\Tab)
+                (write-string "    " out))
+               ((#\Space)
+                (write-char #\Space out)
+                (go escape-spaces))
+               ((#\Linefeed #\Return))
+               (t
+                (write-char char out)))
+             (next-char)
+             (go process-char)))))))
+
+
+(defun encode-for-pre (string)
+  (declare (simple-string string))
+  (let ((output (make-array (truncate (length string) 2/3)
+                            :element-type 'character
+                            :adjustable t
+                            :fill-pointer 0)))
+    (with-output-to-string (out output)
+      (loop for char across string
+            do (case char
+                 ((#\&) (write-string "&" out))
+                 ((#\<) (write-string "<" out))
+                 ((#\>) (write-string ">" out))
+                 (t (write-char char out)))))
+    (coerce output 'simple-string)))
+
+
+(defun encode-for-http (string)
+  (declare (simple-string string))
+  (with-output-to-string (out)
+    (loop for char across string
+          do (write-char char out)
+          when (char= char #\>)
+          do (write-char #\Newline out))))