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.25 2003/05/09 00:05:13 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 ;;;; *************************************************************************
24 (defmacro string-append (outputstr &rest args)
25 `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
27 (defun list-to-string (lst)
28 "Converts a list to a string, doesn't include any delimiters between elements"
29 (format nil "~{~A~}" lst))
31 (defun count-string-words (str)
32 (declare (simple-string str)
33 (optimize (speed 3) (safety 0)))
36 (declare (fixnum n-words))
37 (dotimes (i (length str))
38 (let ((ch (char str i)))
39 (declare (character ch))
40 (if (alphanumericp ch)
47 ;; From Larry Hunter with modifications
48 (defun position-char (char string start max)
49 (declare (optimize (speed 3) (safety 0) (space 0))
50 (fixnum start max) (simple-string string))
51 (do* ((i start (1+ i)))
54 (when (char= char (schar string i)) (return i))))
56 (defun delimited-string-to-list (string &optional (separator #\space)
58 "split a string with delimiter"
59 (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
61 (type character separator))
62 (do* ((len (length string))
65 (end (position-char separator string pos len)
66 (position-char separator string pos len)))
69 (push (subseq string pos) output)
70 (when (or (not skip-terminal) (zerop len))
73 (declare (type fixnum pos len)
74 (type (or null fixnum) end))
75 (push (subseq string pos end) output)
79 (defun list-to-delimited-string (list &optional (separator #\space))
80 (format nil (format nil "~~{~~A~~^~A~~}" separator) list))
82 (defun string-invert (str)
83 "Invert case of a string"
84 (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
86 (let ((up nil) (down nil))
88 (loop for char of-type character across str do
89 (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
90 ((lower-case-p char) (if up (return-from skip str) (setf down t)))))
91 (if up (string-downcase str) (string-upcase str)))))
93 (defun add-sql-quotes (s)
94 (substitute-string-for-char s #\' "''"))
96 (defun escape-backslashes (s)
97 (substitute-string-for-char s #\\ "\\\\"))
99 (defun substitute-string-for-char (procstr match-char subst-str)
100 "Substitutes a string for a single matching character of a string"
101 (substitute-chars-strings procstr (list (cons match-char subst-str))))
103 (defun string-substitute (string substring replacement-string)
104 "String substitute by Larry Hunter. Obtained from Google"
105 (let ((substring-length (length substring))
109 (search substring string)
110 (search substring string :start2 last-end)))
112 (concatenate 'string new-string (subseq string last-end)))
116 (subseq string last-end next-start)
118 (setq last-end (+ next-start substring-length)))))
120 (defun string-trim-last-character (s)
121 "Return the string less the last character"
122 (let ((len (length s)))
124 (subseq s 0 (1- len))
127 (defun nstring-trim-last-character (s)
128 "Return the string less the last character"
129 (let ((len (length s)))
131 (nsubseq s 0 (1- len))
134 (defun string-hash (str &optional (bitmask 65535))
136 (declare (fixnum hash)
138 (dotimes (i (length str))
140 (setq hash (+ hash (char-code (char str i)))))
141 (logand hash bitmask)))
143 (defun string-not-null? (str)
144 (and str (not (zerop (length str)))))
146 (defun whitespace? (c)
147 (declare (character c))
148 (locally (declare (optimize (speed 3) (safety 0)))
149 (or (char= c #\Space) (char= c #\Tab) (char= c #\Return)
150 (char= c #\Linefeed))))
152 (defun not-whitespace? (c)
153 (not (whitespace? c)))
155 (defun string-ws? (str)
156 "Return t if string is all whitespace"
158 (null (find-if #'not-whitespace? str))))
160 (defun replaced-string-length (str repl-alist)
161 (declare (string str))
162 (let* ((orig-len (length str))
164 (declare (fixnum orig-len new-len))
165 (dotimes (i orig-len)
167 (let* ((c (char str i))
168 (match (assoc c repl-alist :test #'char=)))
169 (declare (character c))
171 (incf new-len (1- (length (cdr match)))))))
174 (defun substitute-chars-strings (str repl-alist)
175 "Replace all instances of a chars with a string. repl-alist is an assoc
176 list of characters and replacement strings."
177 (declare (simple-string str))
178 (do* ((orig-len (length str))
179 (new-string (make-string (replaced-string-length str repl-alist)))
184 (declare (fixnum spos dpos) (simple-string new-string))
185 (let* ((c (char str spos))
186 (match (assoc c repl-alist :test #'char=)))
187 (declare (character c))
189 (let* ((subst (cdr match))
190 (len (length subst)))
191 (declare (fixnum len))
194 (setf (char new-string dpos) (char subst j))
197 (setf (char new-string dpos) c)
200 (defun escape-xml-string (string)
201 "Escape invalid XML characters"
202 (substitute-chars-strings
203 string '((#\& . "&") (#\> . ">") (#\< . "<") (#\" . """))))
206 (defun make-usb8-array (len)
207 (make-array len :adjustable nil
209 :element-type '(unsigned-byte 8)))
211 (defun usb8-array-to-string (vec)
212 (let* ((len (length vec))
213 (str (make-string len)))
214 (declare (fixnum len)
216 (optimize (speed 3)))
219 (setf (schar str i) (code-char (aref vec i))))
222 (defun string-to-usb8-array (str)
223 (let* ((len (length str))
224 (vec (make-usb8-array len)))
225 (declare (fixnum len)
226 (type (array fixnum (*)) vec)
227 (optimize (speed 3)))
230 (setf (aref vec i) (char-code (schar str i))))
233 (defun concat-separated-strings (separator &rest lists)
234 (format nil (format nil "~~{~~A~~^~A~~}" separator) (append-sublists lists)))
236 (defun only-null-list-elements-p (lst)
237 (or (null lst) (every #'null lst)))
239 (defun print-separated-strings (strm separator &rest lists)
240 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
241 (compilation-speed 0)))
242 (do* ((rest-lists lists (cdr rest-lists))
243 (list (car rest-lists) (car rest-lists))
244 (last-list (only-null-list-elements-p (cdr rest-lists))
245 (only-null-list-elements-p (cdr rest-lists))))
246 ((null rest-lists) strm)
247 (do* ((lst list (cdr lst))
248 (elem (car lst) (car lst))
249 (last-elem (null (cdr lst)) (null (cdr lst))))
251 (write-string elem strm)
252 (unless (and last-elem last-list)
253 (write-string separator strm)))))