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.17 2003/05/04 14:52:10 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)
48 (defun delimited-string-to-list (string &optional (separator #\space))
49 (excl:delimited-string-to-list string separator))
52 (defun delimited-string-to-list (sequence &optional (separator #\space))
53 "Split a string by a delimitor"
56 for end = (position separator sequence :start start)
57 collect (subseq sequence start end)
60 (setf start (1+ end))))
62 (defun ndelimited-string-to-list (sequence &optional (separator #\space))
63 "Split a string by a delimitor"
66 for end = (position separator sequence :start start)
67 collect (nsubseq sequence start end)
70 (setf start (1+ end))))
73 (defun list-to-delimited-string (list &optional (separator #\space))
74 (excl:list-to-delimited-string list separator))
77 (defun list-to-delimited-string (list &optional (separator #\space))
79 (let ((fmt (format nil "~~A~~{~A~~A~~}" separator)))
80 (format nil fmt (first list) (rest list)))
83 (defun string-invert (str)
84 "Invert case of a string"
85 (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
87 (let ((up nil) (down nil))
89 (loop for char of-type character across str do
90 (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
91 ((lower-case-p char) (if up (return-from skip str) (setf down t)))))
92 (if up (string-downcase str) (string-upcase str)))))
94 (defun add-sql-quotes (s)
95 (substitute-string-for-char s #\' "''"))
97 (defun escape-backslashes (s)
98 (substitute-string-for-char s #\\ "\\\\"))
100 (defun substitute-string-for-char (procstr match-char subst-str)
101 "Substitutes a string for a single matching character of a string"
102 (substitute-chars-strings procstr (list (cons match-char subst-str))))
104 (defun string-substitute (string substring replacement-string)
105 "String substitute by Larry Hunter. Obtained from Google"
106 (let ((substring-length (length substring))
110 (search substring string)
111 (search substring string :start2 last-end)))
113 (concatenate 'string new-string (subseq string last-end)))
117 (subseq string last-end next-start)
119 (setq last-end (+ next-start substring-length)))))
121 (defun string-trim-last-character (s)
122 "Return the string less the last character"
123 (let ((len (length s)))
125 (subseq s 0 (1- len))
128 (defun nstring-trim-last-character (s)
129 "Return the string less the last character"
130 (let ((len (length s)))
132 (nsubseq s 0 (1- len))
135 (defun string-hash (str &optional (bitmask 65535))
137 (declare (fixnum hash)
139 (dotimes (i (length str))
141 (setq hash (+ hash (char-code (char str i)))))
142 (logand hash bitmask)))
144 (defun string-not-null? (str)
145 (and str (not (zerop (length str)))))
147 (defun whitespace? (c)
148 (declare (character c))
149 (locally (declare (optimize (speed 3) (safety 0)))
150 (or (char= c #\Space) (char= c #\Tab) (char= c #\Return)
151 (char= c #\Linefeed))))
153 (defun not-whitespace? (c)
154 (not (whitespace? c)))
156 (defun string-ws? (str)
157 "Return t if string is all whitespace"
159 (null (find-if #'not-whitespace? str))))
161 (defun replaced-string-length (str repl-alist)
162 (declare (string str))
163 (let* ((orig-len (length str))
165 (declare (fixnum orig-len new-len))
166 (dotimes (i orig-len)
168 (let* ((c (char str i))
169 (match (assoc c repl-alist :test #'char=)))
170 (declare (character c))
172 (incf new-len (1- (length (cdr match)))))))
175 (defun substitute-chars-strings (str repl-alist)
176 "Replace all instances of a chars with a string. repl-alist is an assoc
177 list of characters and replacement strings."
178 (declare (simple-string str))
179 (do* ((orig-len (length str))
180 (new-string (make-string (replaced-string-length str repl-alist)))
185 (declare (fixnum spos dpos) (simple-string new-string))
186 (let* ((c (char str spos))
187 (match (assoc c repl-alist :test #'char=)))
188 (declare (character c))
190 (let* ((subst (cdr match))
191 (len (length subst)))
192 (declare (fixnum len))
195 (setf (char new-string dpos) (char subst j))
198 (setf (char new-string dpos) c)
201 (defun escape-xml-string (string)
202 "Escape invalid XML characters"
203 (substitute-chars-strings
204 string '((#\& . "&") (#\> . ">") (#\< . "<") (#\" . """))))
207 (defun make-usb8-array (len)
208 (make-array len :adjustable nil
210 :element-type '(unsigned-byte 8)))
212 (defun usb8-array-to-string (vec)
213 (let* ((len (length vec))
214 (str (make-string len)))
215 (declare (fixnum len)
217 (optimize (speed 3)))
220 (setf (schar str i) (code-char (aref vec i))))
223 (defun string-to-usb8-array (str)
224 (let* ((len (length str))
225 (vec (make-usb8-array len)))
226 (declare (fixnum len)
227 (type (array fixnum (*)) vec)
228 (optimize (speed 3)))
231 (setf (aref vec i) (char-code (schar str i))))