X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=strings.lisp;h=6b6d9df01474248c55f72790edd1b905becc4a0d;hp=9c031164a11b1adede58e4811314baf0d46addc0;hb=5738e60dc3724dc7d022d0fd2d5f2dbe337be470;hpb=a377884abb0f3f36a67d335214bf2936b7c32070

diff --git a/strings.lisp b/strings.lisp
index 9c03116..6b6d9df 100644
--- a/strings.lisp
+++ b/strings.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: strings.lisp,v 1.46 2003/07/08 00:12:51 kevin Exp $
+;;;; $Id: strings.lisp,v 1.50 2003/07/21 00:52:56 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -403,9 +403,11 @@ for characters in a string"
   (declare (type (integer 0 15) n))
   (schar +hex-chars+ n))
 
-(defconstant +char-code-0+ (char-code #\0))
+(defconstant +char-code-lower-a+ (char-code #\a))
 (defconstant +char-code-upper-a+ (char-code #\A))
-(declaim (type fixnum +char-code-0+ +char-code-upper-a+))
+(defconstant +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"
@@ -462,16 +464,39 @@ for characters in a string"
 	(setf (schar str dpos) ch)))))
 
 
-(defconstant +char-code-a+ (char-code #\a))
 
-(defun random-string (&optional (len 10))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar +unambigous-charset+
+    "abcdefghjkmnpqrstuvwxyz123456789ABCDEFGHJKLMNPQSRTUVWXYZ")
+  (defconstant +unambigous-length+ (length +unambigous-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))))
+    (:unambigous
+     (schar +unambigous-charset+ (random +unambigous-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)))
+  (let ((s (make-string length)))
     (declare (simple-string s))
-    (dotimes (i len s)
-      (setf (schar s i)
-	    (code-char (+ +char-code-a+ (random 26)))))))
+    (dotimes (i length s)
+      (setf (schar s i) (random-char set)))))
 
 
 (defun first-char (s)
@@ -493,7 +518,7 @@ for characters in a string"
     (symbol (symbol-name v))
     (otherwise (write-to-string v))))
 
-(defun string-left-trim-one-char (char str)
+(defun string-right-trim-one-char (char str)
   (declare (simple-string str))
   (let* ((len (length str))
 	 (last (1- len)))
@@ -503,3 +528,71 @@ for characters in a string"
       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)
+  (let ((len (length str)))
+    (if (<= len maxlen)
+	str
+      (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 ((whitespace? (char) (member char whitespace :test #'char=)))
+    (let ((tokens nil))
+      (do* ((token-start
+             (position-if-not #'whitespace? string) 
+             (when token-end
+               (position-if-not #'whitespace? string :start (1+ token-end))))
+            (token-end
+             (when token-start
+               (position-if #'whitespace? string :start token-start))
+             (when token-start
+               (position-if #'whitespace? 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"
+  (flet ((whitespace? (char) (non-alphanumericp char)))
+    (let ((tokens nil))
+      (do* ((token-start
+             (position-if-not #'whitespace? string) 
+             (when token-end
+               (position-if-not #'whitespace? string :start (1+ token-end))))
+            (token-end
+             (when token-start
+               (position-if #'whitespace? string :start token-start))
+             (when token-start
+               (position-if #'whitespace? string :start token-start))))
+           ((null token-start) (nreverse tokens))
+        (push (subseq string token-start token-end) tokens)))))
+
+