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 '(#& #< #>) '("&amp;" "&lt;" "&gt;"))) - -(defun replace-first-space (str) - (if (char= (elt str 0) #\space) - (concatenate 'string "&nbsp;" (subseq str 1)) - str)) - -(defun encode-for-tt (str) - (replace-first-space (replace-in-string-1 (replace-in-string str '(#& #< #> #\newline #\return #\linefeed #\tab) '("&amp;" "&lt;" "&gt;" "<br>" "" "" "&nbsp;&nbsp;&nbsp;&nbsp;")) #\space "&nbsp;" '(#\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 "&nbsp;" out) + (go escape-spaces)) + process-char + (case char + ((nil) (return)) + ((#\Newline) + (write-string "<br>" out) + (go escape-spaces)) + ((#&) + (write-string "&amp;" out)) + ((#<) + (write-string "&lt;" out)) + ((#>) + (write-string "&gt;" out)) + ((#\Tab) + (write-string "&nbsp;&nbsp;&nbsp;&nbsp;" 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 "&amp;" out)) + ((#<) (write-string "&lt;" out)) + ((#>) (write-string "&gt;" 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))))