1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: strings.lisp
6 ;;;; Purpose: Strings utility functions for KMRCL package
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; $Id: strings.lisp,v 1.6 2003/01/13 21:40:20 kevin Exp $
12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; KMRCL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
21 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
25 (defmacro string-append (outputstr &rest args)
26 `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
28 (defun list-to-string (lst)
29 "Converts a list to a string, doesn't include any delimiters between elements"
30 (format nil "~{~A~}" lst))
32 (defun count-string-words (str)
33 (declare (simple-string str)
34 (optimize (speed 3) (safety 0)))
37 (declare (fixnum n-words))
38 (dotimes (i (length str))
39 (let ((ch (char str i)))
40 (declare (character ch))
41 (if (alphanumericp ch)
49 (defun delimited-string-to-list (string &optional (separator #\space))
50 (excl:delimited-string-to-list string separator))
53 (defun delimited-string-to-list (sequence &optional (separator #\space))
54 "Split a string by a delimitor"
57 for end = (position separator sequence :start start)
58 collect (subseq sequence start end)
61 (setf start (1+ end))))
64 (defun list-to-delimited-string (list &optional (separator #\space))
65 (excl:list-to-delimited-string list separator))
68 (defun list-to-delimited-string (list &optional (separator #\space))
69 (let ((output (when list (format nil "~A" (car list)))))
70 (dolist (obj (rest list))
71 (setq output (concatenate 'string output
72 (format nil "~A" separator)
73 (format nil "~A" obj))))
76 (defun string-invert (str)
77 "Invert case of a string"
78 (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
80 (let ((up nil) (down nil))
82 (loop for char of-type character across str do
83 (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
84 ((lower-case-p char) (if up (return-from skip str) (setf down t)))))
85 (if up (string-downcase str) (string-upcase str)))))
87 (defun add-sql-quotes (s)
88 (substitute-string-for-char s #\' "''"))
90 (defun escape-backslashes (s)
91 (substitute-string-for-char s #\\ "\\\\"))
93 (defun substitute-string-for-char (procstr match-char subst-str)
94 "Substitutes a string for a single matching character of a string"
95 (let ((pos (position match-char procstr)))
98 (subseq procstr 0 pos) subst-str
99 (substitute-string-for-char (subseq procstr (1+ pos)) match-char subst-str))
102 (defun string-substitute (string substring replacement-string)
103 "String substitute by Larry Hunter. Obtained from Google"
104 (let ((substring-length (length substring))
108 (search substring string)
109 (search substring string :start2 last-end)))
111 (concatenate 'string new-string (subseq string last-end)))
115 (subseq string last-end next-start)
117 (setq last-end (+ next-start substring-length)))))
120 (defun string-trim-last-character (s)
121 "Return the string less the last character"
122 (subseq s 0 (1- (length s))))
124 (defun string-hash (str &optional (bitmask 65535))
126 (declare (fixnum hash)
128 (dotimes (i (length str))
130 (setq hash (+ hash (char-code (char str i)))))
131 (logand hash bitmask)))
133 (defun string-not-null? (str)
134 (and str (not (zerop (length str)))))
136 (defun whitespace? (c)
137 (declare (character c))
138 (declare (optimize (speed 3) (safety 0)))
139 (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) (char= c #\Linefeed)))
141 (defun not-whitespace? (c)
142 (not (whitespace? c)))
144 (defun string-ws? (str)
145 "Return t if string is all whitespace"
147 (null (find-if #'not-whitespace? str))))
150 (defun string-replace-chars-strings (str repl-alist)
151 "Replace all instances of a chars with a string. repl-alist is an assoc
152 list of characters and replacement strings."
153 (let* ((orig-len (length str))
155 (declare (fixnum orig-len new-len))
156 (dotimes (i orign-len)
158 (let ((c (schar i str)))
162 (defun escape-xml-string (string)
163 "Escape invalid XML characters"
164 (string-replace-char-string
165 (string-replace-char-string string #\& "&")
168 (defun string-replace-char-string (string repl-char repl-str)
169 "Replace all occurances of repl-char with repl-str"
170 (declare (simple-string string))
171 (let ((count (count repl-char string)))
172 (declare (fixnum count))
175 (locally (declare (optimize (speed 3) (safety 0)))
176 (let* ((old-length (length string))
177 (repl-length (length repl-str))
178 (new-string (make-string (the fixnum
182 (the fixnum (1- repl-length)))))))))
183 (declare (fixnum old-length repl-length)
184 (simple-string new-string))
186 (declare (fixnum newpos))
187 (dotimes (oldpos (length string))
188 (declare (fixnum oldpos))
189 (if (char= repl-char (schar string oldpos))
190 (dotimes (repl-pos repl-length)
191 (declare (fixnum repl-pos))
192 (setf (schar new-string newpos) (schar repl-str repl-pos))
195 (setf (schar new-string newpos) (schar string oldpos))
201 (defun make-usb8-array (len)
202 (make-array len :adjustable nil
204 :element-type '(unsigned-byte 8)))
206 (defun usb8-array-to-string (vec)
207 (let* ((len (length vec))
208 (str (make-string len)))
209 (declare (fixnum len)
211 (optimize (speed 3)))
214 (setf (schar str i) (code-char (aref vec i))))
217 (defun string-to-usb8-array (str)
218 (let* ((len (length str))
219 (vec (make-usb8-array len)))
220 (declare (fixnum len)
221 (type (array fixnum (*)) vec)
222 (optimize (speed 3)))
225 (setf (aref vec i) (char-code (schar str i))))