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.19 2003/05/05 20:08:17 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) skip-terminal)
49 "Uses allegro's internal function since that benchmarks faster than
50 my algorithm. Does allegro use assembly?"
51 (declare (string string) (character separator))
53 (let ((len (length string)))
54 (when (and (plusp len) (char= separator (char string (1- len))))
55 (setq string (subseq string 0 (1- len))))))
56 (excl:delimited-string-to-list string separator))
58 (defun #-allegro delimited-string-to-list
59 #+allegro my-delimited-string-to-list
60 (string &optional (separator #\space) skip-terminal)
61 "split a string with delimiter"
62 (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
64 (type character separator))
65 (do* ((len (length string))
68 (end (position separator string :start pos :end len)
69 (position separator string :start pos :end len)))
72 (push (subseq string pos) output)
73 (unless (or skip-terminal (null output))
76 (declare (type fixnum pos len)
77 (type (or null fixnum) end))
78 (push (subseq string pos end) output)
82 (defun list-to-delimited-string (list &optional (separator #\space))
83 (format nil (format nil "~~{~~A~~^~A~~}" separator) list))
85 (defun string-invert (str)
86 "Invert case of a string"
87 (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
89 (let ((up nil) (down nil))
91 (loop for char of-type character across str do
92 (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
93 ((lower-case-p char) (if up (return-from skip str) (setf down t)))))
94 (if up (string-downcase str) (string-upcase str)))))
96 (defun add-sql-quotes (s)
97 (substitute-string-for-char s #\' "''"))
99 (defun escape-backslashes (s)
100 (substitute-string-for-char s #\\ "\\\\"))
102 (defun substitute-string-for-char (procstr match-char subst-str)
103 "Substitutes a string for a single matching character of a string"
104 (substitute-chars-strings procstr (list (cons match-char subst-str))))
106 (defun string-substitute (string substring replacement-string)
107 "String substitute by Larry Hunter. Obtained from Google"
108 (let ((substring-length (length substring))
112 (search substring string)
113 (search substring string :start2 last-end)))
115 (concatenate 'string new-string (subseq string last-end)))
119 (subseq string last-end next-start)
121 (setq last-end (+ next-start substring-length)))))
123 (defun string-trim-last-character (s)
124 "Return the string less the last character"
125 (let ((len (length s)))
127 (subseq s 0 (1- len))
130 (defun nstring-trim-last-character (s)
131 "Return the string less the last character"
132 (let ((len (length s)))
134 (nsubseq s 0 (1- len))
137 (defun string-hash (str &optional (bitmask 65535))
139 (declare (fixnum hash)
141 (dotimes (i (length str))
143 (setq hash (+ hash (char-code (char str i)))))
144 (logand hash bitmask)))
146 (defun string-not-null? (str)
147 (and str (not (zerop (length str)))))
149 (defun whitespace? (c)
150 (declare (character c))
151 (locally (declare (optimize (speed 3) (safety 0)))
152 (or (char= c #\Space) (char= c #\Tab) (char= c #\Return)
153 (char= c #\Linefeed))))
155 (defun not-whitespace? (c)
156 (not (whitespace? c)))
158 (defun string-ws? (str)
159 "Return t if string is all whitespace"
161 (null (find-if #'not-whitespace? str))))
163 (defun replaced-string-length (str repl-alist)
164 (declare (string str))
165 (let* ((orig-len (length str))
167 (declare (fixnum orig-len new-len))
168 (dotimes (i orig-len)
170 (let* ((c (char str i))
171 (match (assoc c repl-alist :test #'char=)))
172 (declare (character c))
174 (incf new-len (1- (length (cdr match)))))))
177 (defun substitute-chars-strings (str repl-alist)
178 "Replace all instances of a chars with a string. repl-alist is an assoc
179 list of characters and replacement strings."
180 (declare (simple-string str))
181 (do* ((orig-len (length str))
182 (new-string (make-string (replaced-string-length str repl-alist)))
187 (declare (fixnum spos dpos) (simple-string new-string))
188 (let* ((c (char str spos))
189 (match (assoc c repl-alist :test #'char=)))
190 (declare (character c))
192 (let* ((subst (cdr match))
193 (len (length subst)))
194 (declare (fixnum len))
197 (setf (char new-string dpos) (char subst j))
200 (setf (char new-string dpos) c)
203 (defun escape-xml-string (string)
204 "Escape invalid XML characters"
205 (substitute-chars-strings
206 string '((#\& . "&") (#\> . ">") (#\< . "<") (#\" . """))))
209 (defun make-usb8-array (len)
210 (make-array len :adjustable nil
212 :element-type '(unsigned-byte 8)))
214 (defun usb8-array-to-string (vec)
215 (let* ((len (length vec))
216 (str (make-string len)))
217 (declare (fixnum len)
219 (optimize (speed 3)))
222 (setf (schar str i) (code-char (aref vec i))))
225 (defun string-to-usb8-array (str)
226 (let* ((len (length str))
227 (vec (make-usb8-array len)))
228 (declare (fixnum len)
229 (type (array fixnum (*)) vec)
230 (optimize (speed 3)))
233 (setf (aref vec i) (char-code (schar str i))))