X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=strings.lisp;h=6b6d9df01474248c55f72790edd1b905becc4a0d;hp=48a29107a419dc110a0e71176b4d690a20672c32;hb=5738e60dc3724dc7d022d0fd2d5f2dbe337be470;hpb=67e9cc5c98d4c206f81aa07dc977451c13cb46cd diff --git a/strings.lisp b/strings.lisp index 48a2910..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.44 2003/06/17 13:56:38 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,6 +403,20 @@ for characters in a string" (declare (type (integer 0 15) n)) (schar +hex-chars+ n)) +(defconstant +char-code-lower-a+ (char-code #\a)) +(defconstant +char-code-upper-a+ (char-code #\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" + (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 escape-uri-field (query) "Escape non-alphanumeric characters for URI fields" (declare (simple-string query) @@ -426,15 +440,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 unescape-uri-field (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 +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))) - (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 +510,89 @@ 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) + (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))))) + +