X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=strings.lisp;h=9dbe1babdccd7950172033dc0d5c6d9614ff4921;hp=48a29107a419dc110a0e71176b4d690a20672c32;hb=e55fe0dc654bb7cd01e978a7080b6087788f173f;hpb=67e9cc5c98d4c206f81aa07dc977451c13cb46cd

diff --git a/strings.lisp b/strings.lisp
index 48a2910..9dbe1ba 100644
--- a/strings.lisp
+++ b/strings.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: strings.lisp,v 1.44 2003/06/17 13:56:38 kevin Exp $
+;;;; $Id$
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -150,22 +150,32 @@
       (setq hash (+ hash (char-code (char str i)))))
     (logand hash bitmask)))
 
-(defun string-not-null? (str)
-  (and str (not (zerop (length str)))))
-  
-(defun whitespace? (c) 
-  (declare (character c))
-  (locally (declare (optimize (speed 3) (safety 0)))
-    (or (char= c #\Space) (char= c #\Tab) (char= c #\Return)
-	(char= c #\Linefeed))))
+(defun is-string-empty (str)
+  (zerop (length str)))
+
+(defvar *whitespace-chars* '(#\space #\tab #\return #\linefeed
+			     #+allegro #\%space
+			     #+lispworks #\No-Break-Space))
 
-(defun not-whitespace? (c)
-  (not (whitespace? c)))
+(defun is-char-whitespace (c) 
+  (declare (character c) (optimize (speed 3) (safety 0)))
+  (or (char= c #\Space) (char= c #\Tab) (char= c #\Return)
+      (char= c #\Linefeed)
+      #+allegro (char= c #\%space)
+      #+lispworks (char= c #\No-Break-Space)))
 
-(defun string-ws? (str)
+(defun is-string-whitespace (str)
   "Return t if string is all whitespace"
-  (when (stringp str)
-    (null (find-if #'not-whitespace? str))))
+  (every #'is-char-whitespace str))
+
+(defun string-right-trim-whitespace (str)
+  (string-right-trim *whitespace-chars* str))
+
+(defun string-left-trim-whitespace (str)
+  (string-left-trim *whitespace-chars* str))
+
+(defun string-trim-whitespace (str)
+  (string-trim *whitespace-chars* str))
 
 (defun replaced-string-length (str repl-alist)
   (declare (simple-string str)
@@ -403,7 +413,21 @@ for characters in a string"
   (declare (type (integer 0 15) n))
   (schar +hex-chars+ n))
 
-(defun escape-uri-field (query)
+(defconst +char-code-lower-a+ (char-code #\a))
+(defconst +char-code-upper-a+ (char-code #\A))
+(defconst +char-code-0+ (char-code #\0))
+(declaim (type fixnum +char-code-0+ +char-code-upper-a+
+	       +char-code-0))
+
+(defun charhex (ch)
+  "convert hex character to decimal"
+  (let ((code (char-code (char-upcase ch))))
+    (declare (fixnum ch)) 
+    (if (>= code +char-code-upper-a+)
+	(+ 10 (- code +char-code-upper-a+))
+	(- code +char-code-0+))))
+
+(defun encode-uri-string (query)
   "Escape non-alphanumeric characters for URI fields"
   (declare (simple-string query)
 	   (optimize (speed 3) (safety 0) (space 0)))
@@ -426,15 +450,63 @@ for characters in a string"
 	    (setf (schar str dpos) (hexchar (logand c 15))))
 	(setf (schar str dpos) ch)))))
 
-(defconstant +char-code-a+ (char-code #\a))
+(defun decode-uri-string (query)
+  "Unescape non-alphanumeric characters for URI fields"
+  (declare (simple-string query)
+	   (optimize (speed 3) (safety 0) (space 0)))
+  (do* ((count (count-string-char query #\%))
+	(len (length query))
+	(new-len (- len (* 2 count)))
+	(str (make-string new-len))
+	(spos 0 (1+ spos))
+	(dpos 0 (1+ dpos)))
+      ((= spos len) str)
+    (declare (fixnum count len new-len spos dpos)
+	     (simple-string str))
+    (let ((ch (schar query spos)))
+      (if (char= #\% ch)
+	  (let ((c1 (charhex (schar query (1+ spos))))
+		(c2 (charhex (schar query (+ spos 2)))))
+	    (declare (fixnum c1 c2))
+	    (setf (schar str dpos)
+		  (code-char (logior c2 (ash c1 4))))
+	    (incf spos 2))
+	(setf (schar str dpos) ch)))))
+
+
 
-(defun random-string (&optional (len 10))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar +unambiguous-charset+
+    "abcdefghjkmnpqrstuvwxyz123456789ABCDEFGHJKLMNPQSRTUVWXYZ")
+  (defconstant +unambiguous-length+ (length +unambiguous-charset+)))
+
+(defun random-char (&optional (set :lower-alpha))
+  (ecase set
+    (:lower-alpha
+     (code-char (+ +char-code-lower-a+ (random 26))))
+    (:lower-alphanumeric
+     (let ((n (random 36)))
+       (if (>= n 26)
+	   (code-char (+ +char-code-0+ (- n 26)))
+	 (code-char (+ +char-code-lower-a+ n)))))
+    (:upper-alpha
+     (code-char (+ +char-code-upper-a+ (random 26))))
+    (:unambiguous
+     (schar +unambiguous-charset+ (random +unambiguous-length+)))
+    (:upper-lower-alpha
+     (let ((n (random 52)))
+       (if (>= n 26)
+	   (code-char (+ +char-code-upper-a+ (- n 26)))
+	 (code-char (+ +char-code-lower-a+ n)))))))
+     
+
+(defun random-string (&key (length 10) (set :lower-alpha))
   "Returns a random lower-case string."
   (declare (optimize (speed 3)))
-  (let ((s (make-string len)))
-    (declare (simple-string s)
-    (dotimes  (i len s)
-      (setf (schar s i) (code-char (+ +code-char-a+ (random 26))))))))
+  (let ((s (make-string length)))
+    (declare (simple-string s))
+    (dotimes (i length s)
+      (setf (schar s i) (random-char set)))))
 
 
 (defun first-char (s)
@@ -448,3 +520,159 @@ for characters in a string"
     (let ((len (length s)))
       (when (plusp len))
       (schar s (1- len)))))
+
+(defun ensure-string (v)
+  (typecase v
+    (string v)
+    (character (string v))
+    (symbol (symbol-name v))
+    (otherwise (write-to-string v))))
+
+(defun string-right-trim-one-char (char str)
+  (declare (simple-string str))
+  (let* ((len (length str))
+	 (last (1- len)))
+    (declare (fixnum len last))
+    (if (char= char (schar str last))
+	(subseq str 0 last)
+      str)))
+
+
+(defun string-strip-ending (str endings)
+  (if (stringp endings)
+      (setq endings (list endings)))
+  (let ((len (length str)))
+    (dolist (ending endings str)
+      (when (and (>= len (length ending))
+		 (string-equal ending
+			       (subseq str (- len
+					      (length ending)))))
+	(return-from string-strip-ending
+	  (subseq str 0 (- len (length ending))))))))
+       
+
+(defun string-maybe-shorten (str maxlen)
+  (string-elide str maxlen :end))
+
+(defun string-elide (str maxlen position)
+  (declare (fixnum maxlen))
+  (let ((len (length str)))
+    (declare (fixnum len))
+    (cond
+     ((<= len maxlen)
+      str)
+     ((<= maxlen 3)
+      "...")
+     ((eq position :middle)
+      (multiple-value-bind (mid remain) (truncate maxlen 2)
+	(let ((end1 (- mid 1))
+	      (start2 (- len (- mid 2) remain))) 
+	  (concatenate 'string (subseq str 0 end1) "..." (subseq str start2)))))
+     ((or (eq position :end) t)
+      (concatenate 'string (subseq str 0 (- maxlen 3)) "...")))))
+
+(defun shrink-vector (str size)
+  #+allegro
+  (excl::.primcall 'sys::shrink-svector str size)
+  #+cmu
+  (lisp::shrink-vector str size)
+  #+lispworks
+  (system::shrink-vector$vector str size)
+  #+sbcl
+  (sb-kernel:shrink-vector str size)
+  #+scl
+  (common-lisp::shrink-vector str size)
+  #-(or allegro cmu lispworks sbcl scl)
+  (setq str (subseq str 0 size))
+  str)
+
+(defun lex-string (string &key (whitespace '(#\space #\newline)))
+  "Separates a string at whitespace and returns a list of strings"
+  (flet ((is-sep (char) (member char whitespace :test #'char=)))
+    (let ((tokens nil))
+      (do* ((token-start
+             (position-if-not #'is-sep string) 
+             (when token-end
+               (position-if-not #'is-sep string :start (1+ token-end))))
+            (token-end
+             (when token-start
+               (position-if #'is-sep string :start token-start))
+             (when token-start
+               (position-if #'is-sep string :start token-start))))
+           ((null token-start) (nreverse tokens))
+        (push (subseq string token-start token-end) tokens)))))
+
+(defun split-alphanumeric-string (string)
+  "Separates a string at any non-alphanumeric chararacter"
+  (declare (simple-string string)
+	   (optimize (speed 3) (safety 0)))
+  (flet ((is-sep (char) 
+	   (declare (character char))
+	   (and (non-alphanumericp char)
+		(not (char= #\_ char)))))
+    (let ((tokens nil))
+      (do* ((token-start
+             (position-if-not #'is-sep string) 
+             (when token-end
+               (position-if-not #'is-sep string :start (1+ token-end))))
+            (token-end
+             (when token-start
+               (position-if #'is-sep string :start token-start))
+             (when token-start
+               (position-if #'is-sep string :start token-start))))
+           ((null token-start) (nreverse tokens))
+        (push (subseq string token-start token-end) tokens)))))
+
+
+(defun trim-non-alphanumeric (word)
+  "Strip non-alphanumeric characters from beginning and end of a word."
+  (declare (simple-string word)
+	   (optimize (speed 3) (safety 0) (space 0)))
+  (let* ((start 0)
+	 (len (length word))
+	 (end len))
+    (declare (fixnum start end len))
+    (do ((done nil))
+	((or done (= start end)))
+      (if (alphanumericp (schar word start))
+	  (setq done t)
+	(incf start)))
+    (when (> end start)
+      (do ((done nil))
+	  ((or done (= start end)))
+	(if (alphanumericp (schar word (1- end)))
+	    (setq done t)
+	  (decf end))))
+    (if (or (plusp start) (/= len end))
+	(subseq word start end)
+      word)))
+
+	  
+
+(defun collapse-whitespace (s)
+  "Convert multiple whitespace characters to a single space character."
+  (declare (simple-string s)
+	   (optimize (speed 3) (safety 0)))
+  (with-output-to-string (stream)
+    (do ((pos 0 (1+ pos))
+	 (in-white nil)
+	 (len (length s)))
+	((= pos len))
+      (declare (fixnum pos len))
+      (let ((c (schar s pos)))
+	(declare (character c))
+	(cond
+	 ((kl:is-char-whitespace c)
+	  (unless in-white
+	    (write-char #\space stream))
+	  (setq in-white t))
+	 (t
+	  (setq in-white nil)
+	  (write-char c stream)))))))
+
+(defun string->list (string)
+  (let ((eof (list nil)))
+    (with-input-from-string (stream string)
+      (do ((x (read stream nil eof) (read stream nil eof))
+           (l nil (cons x l)))
+          ((eq x eof) (nreverse l))))))