;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2006 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
(defun count-string-words (str)
(declare (simple-string str)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(let ((n-words 0)
- (in-word nil))
+ (in-word nil))
(declare (fixnum n-words))
(do* ((len (length str))
- (i 0 (1+ i)))
- ((= i len) n-words)
+ (i 0 (1+ i)))
+ ((= i len) n-words)
(declare (fixnum i))
(if (alphanumericp (schar str i))
- (unless in-word
- (incf n-words)
- (setq in-word t))
- (setq in-word nil)))))
+ (unless in-word
+ (incf n-words)
+ (setq in-word t))
+ (setq in-word nil)))))
-;; From Larry Hunter with modifications
(defun position-char (char string start max)
(declare (optimize (speed 3) (safety 0) (space 0))
- (fixnum start max) (simple-string string))
+ (fixnum start max) (simple-string string))
(do* ((i start (1+ i)))
((= i max) nil)
(declare (fixnum i))
(defun position-not-char (char string start max)
(declare (optimize (speed 3) (safety 0) (space 0))
- (fixnum start max) (simple-string string))
+ (fixnum start max) (simple-string string))
(do* ((i start (1+ i)))
((= i max) nil)
(declare (fixnum i))
(when (char/= char (schar string i)) (return i))))
-(defun delimited-string-to-list (string &optional (separator #\space)
- skip-terminal)
+(defun delimited-string-to-list (string &optional (separator #\space)
+ skip-terminal)
"split a string with delimiter"
(declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
- (type string string)
- (type character separator))
+ (type string string)
+ (type character separator))
(do* ((len (length string))
- (output '())
- (pos 0)
- (end (position-char separator string pos len)
- (position-char separator string pos len)))
+ (output '())
+ (pos 0)
+ (end (position-char separator string pos len)
+ (position-char separator string pos len)))
((null end)
- (if (< pos len)
- (push (subseq string pos) output)
- (when (or (not skip-terminal) (zerop len))
- (push "" output)))
- (nreverse output))
+ (if (< pos len)
+ (push (subseq string pos) output)
+ (when (or (not skip-terminal) (zerop len))
+ (push "" output)))
+ (nreverse output))
(declare (type fixnum pos len)
- (type (or null fixnum) end))
+ (type (or null fixnum) end))
(push (subseq string pos end) output)
(setq pos (1+ end))))
(let ((up nil) (down nil))
(block skip
(loop for char of-type character across str do
- (cond ((upper-case-p char)
- (if down (return-from skip str) (setf up t)))
- ((lower-case-p char)
- (if up (return-from skip str) (setf down t)))))
+ (cond ((upper-case-p char)
+ (if down (return-from skip str) (setf up t)))
+ ((lower-case-p char)
+ (if up (return-from skip str) (setf down t)))))
(if up (string-downcase str) (string-upcase str)))))
(defun add-sql-quotes (s)
(defun escape-backslashes (s)
(substitute-string-for-char s #\\ "\\\\"))
-(defun substitute-string-for-char (procstr match-char subst-str)
+(defun substitute-string-for-char (procstr match-char subst-str)
"Substitutes a string for a single matching character of a string"
(substitute-chars-strings procstr (list (cons match-char subst-str))))
(defun string-substitute (string substring replacement-string)
"String substitute by Larry Hunter. Obtained from Google"
(let ((substring-length (length substring))
- (last-end 0)
- (new-string ""))
+ (last-end 0)
+ (new-string ""))
(do ((next-start
- (search substring string)
- (search substring string :start2 last-end)))
- ((null next-start)
- (concatenate 'string new-string (subseq string last-end)))
+ (search substring string)
+ (search substring string :start2 last-end)))
+ ((null next-start)
+ (concatenate 'string new-string (subseq string last-end)))
(setq new-string
- (concatenate 'string
- new-string
- (subseq string last-end next-start)
- replacement-string))
+ (concatenate 'string
+ new-string
+ (subseq string last-end next-start)
+ replacement-string))
(setq last-end (+ next-start substring-length)))))
(defun string-trim-last-character (s)
"Return the string less the last character"
(let ((len (length s)))
(if (plusp len)
- (subseq s 0 (1- len))
- s)))
+ (subseq s 0 (1- len))
+ s)))
(defun nstring-trim-last-character (s)
"Return the string less the last character"
(let ((len (length s)))
(if (plusp len)
- (nsubseq s 0 (1- len))
- s)))
+ (nsubseq s 0 (1- len))
+ s)))
(defun string-hash (str &optional (bitmask 65535))
(let ((hash 0))
(declare (fixnum hash)
- (simple-string str))
+ (simple-string str))
(dotimes (i (length str))
(declare (fixnum i))
(setq hash (+ hash (char-code (char str i)))))
(zerop (length str)))
(defvar *whitespace-chars* '(#\space #\tab #\return #\linefeed
- #+allegro #\%space
- #+lispworks #\No-Break-Space))
+ #+allegro #\%space
+ #+lispworks #\No-Break-Space))
-(defun is-char-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)
(defun replaced-string-length (str repl-alist)
(declare (simple-string str)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(do* ((i 0 (1+ i))
- (orig-len (length str))
- (new-len orig-len))
- ((= i orig-len) new-len)
+ (orig-len (length str))
+ (new-len orig-len))
+ ((= i orig-len) new-len)
(declare (fixnum i orig-len new-len))
(let* ((c (char str i))
- (match (assoc c repl-alist :test #'char=)))
- (declare (character c))
- (when match
- (incf new-len (1- (length
- (the simple-string (cdr match)))))))))
+ (match (assoc c repl-alist :test #'char=)))
+ (declare (character c))
+ (when match
+ (incf new-len (1- (length
+ (the simple-string (cdr match)))))))))
(defun substitute-chars-strings (str repl-alist)
"Replace all instances of a chars with a string. repl-alist is an assoc
list of characters and replacement strings."
(declare (simple-string str)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(do* ((orig-len (length str))
- (new-string (make-string (replaced-string-length str repl-alist)))
- (spos 0 (1+ spos))
- (dpos 0))
+ (new-string (make-string (replaced-string-length str repl-alist)))
+ (spos 0 (1+ spos))
+ (dpos 0))
((>= spos orig-len)
new-string)
(declare (fixnum spos dpos) (simple-string new-string))
(let* ((c (char str spos))
- (match (assoc c repl-alist :test #'char=)))
+ (match (assoc c repl-alist :test #'char=)))
(declare (character c))
(if match
- (let* ((subst (cdr match))
- (len (length subst)))
- (declare (fixnum len)
- (simple-string subst))
- (dotimes (j len)
- (declare (fixnum j))
- (setf (char new-string dpos) (char subst j))
- (incf dpos)))
- (progn
- (setf (char new-string dpos) c)
- (incf dpos))))))
+ (let* ((subst (cdr match))
+ (len (length subst)))
+ (declare (fixnum len)
+ (simple-string subst))
+ (dotimes (j len)
+ (declare (fixnum j))
+ (setf (char new-string dpos) (char subst j))
+ (incf dpos)))
+ (progn
+ (setf (char new-string dpos) c)
+ (incf dpos))))))
(defun escape-xml-string (string)
"Escape invalid XML characters"
(defun make-usb8-array (len)
(make-array len :element-type '(unsigned-byte 8)))
-(defun usb8-array-to-string (vec)
- (declare (type (simple-array (unsigned-byte 8) (*)) vec))
- (let* ((len (length vec))
- (str (make-string len)))
+(defun usb8-array-to-string (vec &key (start 0) end)
+ (declare (type (simple-array (unsigned-byte 8) (*)) vec)
+ (fixnum start))
+ (unless end
+ (setq end (length vec)))
+ (let* ((len (- end start))
+ (str (make-string len)))
(declare (fixnum len)
- (simple-string str)
- (optimize (speed 3)))
+ (simple-string str)
+ (optimize (speed 3) (safety 0)))
(do ((i 0 (1+ i)))
- ((= i len) str)
+ ((= i len) str)
(declare (fixnum i))
- (setf (schar str i) (code-char (aref vec i))))))
+ (setf (schar str i) (code-char (aref vec (the fixnum (+ i start))))))))
(defun string-to-usb8-array (str)
(declare (simple-string str))
(let* ((len (length str))
- (vec (make-usb8-array len)))
+ (vec (make-usb8-array len)))
(declare (fixnum len)
- (type (simple-array (unsigned-byte 8) (*)) vec)
- (optimize (speed 3)))
+ (type (simple-array (unsigned-byte 8) (*)) vec)
+ (optimize (speed 3)))
(do ((i 0 (1+ i)))
- ((= i len) vec)
+ ((= i len) vec)
(declare (fixnum i))
(setf (aref vec i) (char-code (schar str i))))))
(defun concat-separated-strings (separator &rest lists)
(format nil (concatenate 'string "~{~A~^" (string separator) "~}")
- (append-sublists lists)))
+ (append-sublists lists)))
(defun only-null-list-elements-p (lst)
(or (null lst) (every #'null lst)))
(defun print-separated-strings (strm separator &rest lists)
(declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
- (compilation-speed 0)))
+ (compilation-speed 0)))
(do* ((rest-lists lists (cdr rest-lists))
- (list (car rest-lists) (car rest-lists))
- (last-list (only-null-list-elements-p (cdr rest-lists))
- (only-null-list-elements-p (cdr rest-lists))))
+ (list (car rest-lists) (car rest-lists))
+ (last-list (only-null-list-elements-p (cdr rest-lists))
+ (only-null-list-elements-p (cdr rest-lists))))
((null rest-lists) strm)
(do* ((lst list (cdr lst))
- (elem (car lst) (car lst))
- (last-elem (null (cdr lst)) (null (cdr lst))))
- ((null lst))
+ (elem (car lst) (car lst))
+ (last-elem (null (cdr lst)) (null (cdr lst))))
+ ((null lst))
(write-string elem strm)
(unless (and last-elem last-list)
- (write-string separator strm)))))
+ (write-string separator strm)))))
-(defun prefixed-fixnum-string (num pchar len)
- "Outputs a string of LEN digit with an optional initial character PCHAR.
-Leading zeros are present."
- (declare (optimize (speed 3) (safety 0) (space 0))
- (type fixnum num len))
- (when pchar
- (incf len))
- (do* ((zero-code (char-code #\0))
- (result (make-string len :initial-element #\0))
- (minus? (minusp num))
- (val (if minus? (- num) num)
- (nth-value 0 (floor val 10)))
- (pos (1- len) (1- pos))
- (mod (mod val 10) (mod val 10)))
- ((or (zerop val) (minusp pos))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmacro def-prefixed-number-string (fn-name type &optional doc)
+ `(defun ,fn-name (num pchar len)
+ ,@(when (stringp doc) (list doc))
+ (declare (optimize (speed 3) (safety 0) (space 0))
+ (fixnum len)
+ (,type num))
(when pchar
- (setf (schar result 0) pchar))
- (when minus? (setf (schar result (if pchar 1 0)) #\-))
- result)
- (declare (fixnum val mod zero-code pos) (simple-string result))
- (setf (schar result pos) (code-char (+ zero-code mod)))))
+ (incf len))
+ (do* ((zero-code (char-code #\0))
+ (result (make-string len :initial-element #\0))
+ (minus? (minusp num))
+ (val (if minus? (- num) num)
+ (nth-value 0 (floor val 10)))
+ (pos (1- len) (1- pos))
+ (mod (mod val 10) (mod val 10)))
+ ((or (zerop val) (minusp pos))
+ (when pchar
+ (setf (schar result 0) pchar))
+ (when minus? (setf (schar result (if pchar 1 0)) #\-))
+ result)
+ (declare (,type val)
+ (fixnum mod zero-code pos)
+ (boolean minus?)
+ (simple-string result))
+ (setf (schar result pos) (code-char (the fixnum (+ zero-code mod))))))))
+
+(def-prefixed-number-string prefixed-fixnum-string fixnum
+ "Outputs a string of LEN digit with an optional initial character PCHAR.
+Leading zeros are present. LEN must be a fixnum.")
+
+(def-prefixed-number-string prefixed-integer-string integer
+ "Outputs a string of LEN digit with an optional initial character PCHAR.
+Leading zeros are present. LEN must be an integer.")
(defun integer-string (num len)
"Outputs a string of LEN digit with an optional initial character PCHAR.
Leading zeros are present."
(declare (optimize (speed 3) (safety 0) (space 0))
- (type fixnum len)
- (type integer num))
+ (type fixnum len)
+ (type integer num))
(do* ((zero-code (char-code #\0))
- (result (make-string len :initial-element #\0))
- (minus? (minusp num))
- (val (if minus? (- 0 num) num)
- (nth-value 0 (floor val 10)))
- (pos (1- len) (1- pos))
- (mod (mod val 10) (mod val 10)))
+ (result (make-string len :initial-element #\0))
+ (minus? (minusp num))
+ (val (if minus? (- 0 num) num)
+ (nth-value 0 (floor val 10)))
+ (pos (1- len) (1- pos))
+ (mod (mod val 10) (mod val 10)))
((or (zerop val) (minusp pos))
(when minus? (setf (schar result 0) #\-))
result)
(defun fast-string-search (substr str substr-length startpos endpos)
"Optimized search for a substring in a simple-string"
(declare (simple-string substr str)
- (fixnum substr-length startpos endpos)
- (optimize (speed 3) (space 0) (safety 0)))
+ (fixnum substr-length startpos endpos)
+ (optimize (speed 3) (space 0) (safety 0)))
(do* ((pos startpos (1+ pos))
- (lastpos (- endpos substr-length)))
+ (lastpos (- endpos substr-length)))
((> pos lastpos) nil)
(declare (fixnum pos lastpos))
(do ((i 0 (1+ i)))
- ((= i substr-length)
- (return-from fast-string-search pos))
+ ((= i substr-length)
+ (return-from fast-string-search pos))
(declare (fixnum i))
(unless (char= (schar str (+ i pos)) (schar substr i))
- (return nil)))))
+ (return nil)))))
(defun string-delimited-string-to-list (str substr)
"splits a string delimited by substr into a list of strings"
(declare (simple-string str substr)
- (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)
- (debug 0)))
+ (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)
+ (debug 0)))
(do* ((substr-len (length substr))
- (strlen (length str))
- (output '())
- (pos 0)
- (end (fast-string-search substr str substr-len pos strlen)
- (fast-string-search substr str substr-len pos strlen)))
+ (strlen (length str))
+ (output '())
+ (pos 0)
+ (end (fast-string-search substr str substr-len pos strlen)
+ (fast-string-search substr str substr-len pos strlen)))
((null end)
- (when (< pos strlen)
- (push (subseq str pos) output))
- (nreverse output))
+ (when (< pos strlen)
+ (push (subseq str pos) output))
+ (nreverse output))
(declare (fixnum strlen substr-len pos)
- (type (or fixnum null) end))
+ (type (or fixnum null) end))
(push (subseq str pos end) output)
(setq pos (+ end substr-len))))
-
+
(defun string-to-list-skip-delimiter (str &optional (delim #\space))
"Return a list of strings, delimited by spaces, skipping spaces."
(declare (simple-string str)
- (optimize (speed 0) (space 0) (safety 0)))
+ (optimize (speed 0) (space 0) (safety 0)))
(do* ((results '())
- (end (length str))
- (i (position-not-char delim str 0 end)
- (position-not-char delim str j end))
- (j (when i (position-char delim str i end))
- (when i (position-char delim str i end))))
+ (end (length str))
+ (i (position-not-char delim str 0 end)
+ (position-not-char delim str j end))
+ (j (when i (position-char delim str i end))
+ (when i (position-char delim str i end))))
((or (null i) (null j))
- (when (and i (< i end))
- (push (subseq str i end) results))
- (nreverse results))
+ (when (and i (< i end))
+ (push (subseq str i end) results))
+ (nreverse results))
(declare (fixnum end)
- (type (or fixnum null) i j))
+ (type (or fixnum null) i j))
(push (subseq str i j) results)))
(defun string-starts-with (start str)
(defun count-string-char (s c)
"Return a count of the number of times a character appears in a string"
(declare (simple-string s)
- (character c)
- (optimize (speed 3) (safety 0)))
+ (character c)
+ (optimize (speed 3) (safety 0)))
(do ((len (length s))
(i 0 (1+ i))
(count 0))
"Return a count of the number of times a predicate is true
for characters in a string"
(declare (simple-string s)
- (type (or function symbol) pred)
- (optimize (speed 3) (safety 0) (space 0)))
+ (type (or function symbol) pred)
+ (optimize (speed 3) (safety 0) (space 0)))
(do ((len (length s))
(i 0 (1+ i))
(count 0))
(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))
+(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))
+ +char-code-0))
(defun charhex (ch)
"convert hex character to decimal"
(let ((code (char-code (char-upcase ch))))
- (declare (fixnum ch))
+ (declare (fixnum ch))
(if (>= code +char-code-upper-a+)
- (+ 10 (- code +char-code-upper-a+))
- (- code +char-code-0+))))
+ (+ 10 (- code +char-code-upper-a+))
+ (- code +char-code-0+))))
+
+(defun binary-sequence-to-hex-string (seq)
+ (let ((list (etypecase seq
+ (list seq)
+ (sequence (map 'list #'identity seq)))))
+ (string-downcase (format nil "~{~2,'0X~}" list))))
(defun encode-uri-string (query)
"Escape non-alphanumeric characters for URI fields"
(declare (simple-string query)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(do* ((count (count-string-char-if #'non-alphanumericp query))
- (len (length query))
- (new-len (+ len (* 2 count)))
- (str (make-string new-len))
- (spos 0 (1+ spos))
- (dpos 0 (1+ dpos)))
+ (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))
+ (simple-string str))
(let ((ch (schar query spos)))
(if (non-alphanumericp ch)
- (let ((c (char-code ch)))
- (setf (schar str dpos) #\%)
- (incf dpos)
- (setf (schar str dpos) (hexchar (logand (ash c -4) 15)))
- (incf dpos)
- (setf (schar str dpos) (hexchar (logand c 15))))
- (setf (schar str dpos) ch)))))
+ (let ((c (char-code ch)))
+ (setf (schar str dpos) #\%)
+ (incf dpos)
+ (setf (schar str dpos) (hexchar (logand (ash c -4) 15)))
+ (incf dpos)
+ (setf (schar str dpos) (hexchar (logand c 15))))
+ (setf (schar str dpos) ch)))))
(defun decode-uri-string (query)
"Unescape non-alphanumeric characters for URI fields"
(declare (simple-string query)
- (optimize (speed 3) (safety 0) (space 0)))
+ (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)))
+ (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))
+ (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)))))
-
-
+ (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 uri-query-to-alist (query)
+ "Converts non-decoded URI query to an alist of settings"
+ (mapcar (lambda (set)
+ (let ((lst (kmrcl:delimited-string-to-list set #\=)))
+ (cons (first lst) (second lst))))
+ (kmrcl:delimited-string-to-list
+ (kmrcl:decode-uri-string query) #\&)))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar +unambigous-charset+
+ (defvar +unambiguous-charset+
"abcdefghjkmnpqrstuvwxyz123456789ABCDEFGHJKLMNPQSRTUVWXYZ")
- (defconstant +unambigous-length+ (length +unambigous-charset+)))
+ (defconstant* +unambiguous-length+ (length +unambiguous-charset+)))
(defun random-char (&optional (set :lower-alpha))
(ecase set
(:lower-alphanumeric
(let ((n (random 36)))
(if (>= n 26)
- (code-char (+ +char-code-0+ (- n 26)))
- (code-char (+ +char-code-lower-a+ n)))))
+ (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+)))
+ (: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)))))))
-
+ (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."
(defun string-right-trim-one-char (char str)
(declare (simple-string str))
(let* ((len (length str))
- (last (1- len)))
+ (last (1- len)))
(declare (fixnum len last))
(if (char= char (schar str last))
- (subseq str 0 last)
+ (subseq str 0 last)
str)))
+(defun remove-char-string (char str)
+ (declare (character char)
+ (string str))
+ (do* ((len (length str))
+ (out (make-string len))
+ (pos 0 (1+ pos))
+ (opos 0))
+ ((= pos len) (subseq out 0 opos))
+ (declare (fixnum pos opos len)
+ (simple-string out))
+ (let ((c (char str pos)))
+ (declare (character c))
+ (when (char/= c char)
+ (setf (schar out opos) c)
+ (incf opos)))))
+
+
(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))))))))
-
+ (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)) "..."))))
+ (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
(flet ((is-sep (char) (member char whitespace :test #'char=)))
(let ((tokens nil))
(do* ((token-start
- (position-if-not #'is-sep string)
+ (position-if-not #'is-sep string)
(when token-end
(position-if-not #'is-sep string :start (1+ token-end))))
(token-end
(defun split-alphanumeric-string (string)
"Separates a string at any non-alphanumeric chararacter"
- (flet ((is-sep (char) (non-alphanumericp char)))
+ (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)
+ (position-if-not #'is-sep string)
(when token-end
(position-if-not #'is-sep string :start (1+ token-end))))
(token-end
(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)))
+ (optimize (speed 3) (safety 0)))
(with-output-to-string (stream)
(do ((pos 0 (1+ pos))
- (in-white nil)
- (len (length s)))
- ((= pos len))
+ (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)))))))
+ (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)))
projects / kmrcl.git / blobdiff