strings.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          strings.lisp
   6 ;;;; Purpose:       Strings utility functions for KMRCL package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: strings.lisp,v 1.8 2003/04/28 16:07:43 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  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 ;;;; *************************************************************************
  18
  19
  20 (in-package :kmrcl)
  21 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
  22
  23 ;;; Strings
  24
  25 (defmacro string-append (outputstr &rest args)
  26   `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
  27
  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))
  31
  32 (defun count-string-words (str)
  33   (declare (simple-string str)
  34            (optimize (speed 3) (safety 0)))
  35   (let ((n-words 0)
  36         (in-word nil))
  37     (declare (fixnum n-words))
  38     (dotimes (i (length str))
  39       (let ((ch (char str i)))
  40         (declare (character ch))
  41         (if (alphanumericp ch)
  42             (unless in-word
  43               (incf n-words)
  44               (setq in-word t))
  45           (setq in-word nil))))
  46     n-words))
  47
  48 #+excl
  49 (defun delimited-string-to-list (string &optional (separator #\space))
  50   (excl:delimited-string-to-list string separator))
  51
  52 #-excl
  53 (defun delimited-string-to-list (sequence &optional (separator #\space))
  54   "Split a string by a delimitor"
  55   (loop
  56       with start = 0
  57       for end = (position separator sequence :start start)
  58       collect (subseq sequence start end)
  59       until (null end)
  60       do
  61     (setf start (1+ end))))
  62
  63 #+excl
  64 (defun list-to-delimited-string (list &optional (separator #\space))
  65   (excl:list-to-delimited-string list separator))
  66
  67 #-excl
  68 (defun list-to-delimited-string (list &optional (separator #\space))
  69   (if (consp list)
  70       (let ((fmt (format nil "~~A~~{~A~~A~~}" separator)))
  71         (format nil fmt (first list) (rest list)))
  72       ""))
  73
  74 (defun string-invert (str)
  75   "Invert case of a string"
  76   (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
  77            (simple-string str))
  78   (let ((up nil) (down nil))
  79     (block skip
  80       (loop for char of-type character across str do
  81             (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
  82                   ((lower-case-p char) (if up   (return-from skip str) (setf down t)))))
  83       (if up (string-downcase str) (string-upcase str)))))
  84
  85 (defun add-sql-quotes (s)
  86   (substitute-string-for-char s #\' "''"))
  87
  88 (defun escape-backslashes (s)
  89   (substitute-string-for-char s #\\ "\\\\"))
  90
  91 (defun substitute-string-for-char (procstr match-char subst-str)
  92   "Substitutes a string for a single matching character of a string"
  93   (let ((pos (position match-char procstr)))
  94     (if pos
  95         (concatenate 'string
  96           (subseq procstr 0 pos) subst-str
  97           (substitute-string-for-char (subseq procstr (1+ pos)) match-char subst-str))
  98       procstr)))
  99
 100 (defun string-substitute (string substring replacement-string)
 101   "String substitute by Larry Hunter. Obtained from Google"
 102   (let ((substring-length (length substring))
 103         (last-end 0)
 104         (new-string ""))
 105     (do ((next-start
 106           (search substring string)
 107           (search substring string :start2 last-end)))
 108         ((null next-start)
 109          (concatenate 'string new-string (subseq string last-end)))
 110       (setq new-string
 111         (concatenate 'string
 112           new-string
 113           (subseq string last-end next-start)
 114           replacement-string))
 115       (setq last-end (+ next-start substring-length)))))
 116
 117
 118 (defun string-trim-last-character (s)
 119 "Return the string less the last character"
 120   (subseq s 0 (1- (length s))))
 121
 122 (defun string-hash (str &optional (bitmask 65535))
 123   (let ((hash 0))
 124     (declare (fixnum hash)
 125              (simple-string str))
 126     (dotimes (i (length str))
 127       (declare (fixnum i))
 128       (setq hash (+ hash (char-code (char str i)))))
 129     (logand hash bitmask)))
 130
 131 (defun string-not-null? (str)
 132   (and str (not (zerop (length str)))))
 133
 134 (defun whitespace? (c)
 135   (declare (character c))
 136   (declare (optimize (speed 3) (safety 0)))
 137   (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) (char= c #\Linefeed)))
 138
 139 (defun not-whitespace? (c)
 140   (not (whitespace? c)))
 141
 142 (defun string-ws? (str)
 143   "Return t if string is all whitespace"
 144   (when (stringp str)
 145     (null (find-if #'not-whitespace? str))))
 146
 147 (defun string-replace-chars-strings (str repl-alist)
 148   "Replace all instances of a chars with a string. repl-alist is an assoc
 149 list of characters and replacement strings."
 150   (declare (string str))
 151   (let* ((orig-len (length str))
 152          (new-len orig-len))
 153     (declare (fixnum orig-len new-len))
 154     (dotimes (i orig-len)
 155       (declare (fixnum i))
 156       (let* ((c (char str i))
 157              (match (assoc c repl-alist :test #'char=)))
 158         (declare (character c))
 159         (when match
 160           (incf new-len (length (cdr match))))))
 161     (let ((new-string (make-string new-len))
 162           (i 0))
 163       (declare (string new-string)
 164                (fixnum i))
 165       (dotimes (i orig-len)
 166         (declare (fixnum i))
 167         (let* ((c (char str i))
 168                (match (assoc c repl-alist :test #'char=)))
 169           (declare (character c))
 170           (if match
 171               (let ((subst (cdr match)))
 172                 (dotimes (j (length subst))
 173                   (setf (char new-string i) (char subst j))
 174                   (incf i)))
 175             (progn
 176               (setf (char new-string i) c)))))
 177       new-string)))
 178
 179 (defun escape-xml-string (string)
 180   "Escape invalid XML characters"
 181   (string-replace-char-string
 182    (string-replace-char-string string #\& "&amp;")
 183    #\< "&lt;"))
 184
 185 (defun string-replace-char-string (string repl-char repl-str)
 186   "Replace all occurances of repl-char with repl-str"
 187  (declare (simple-string string))
 188   (let ((count (count repl-char string)))
 189     (declare (fixnum count))
 190     (if (zerop count)
 191         string
 192         (locally (declare (optimize (speed 3) (safety 0)))
 193           (let* ((old-length (length string))
 194                  (repl-length (length repl-str))
 195                  (new-string (make-string (the fixnum
 196                                             (+ old-length
 197                                                (the fixnum
 198                                                  (* count
 199                                                     (the fixnum (1- repl-length)))))))))
 200             (declare (fixnum old-length repl-length)
 201                      (simple-string new-string))
 202             (let ((newpos 0))
 203               (declare (fixnum newpos))
 204               (dotimes (oldpos (length string))
 205                 (declare (fixnum oldpos))
 206                 (if (char= repl-char (schar string oldpos))
 207                     (dotimes (repl-pos repl-length)
 208                       (declare (fixnum repl-pos))
 209                       (setf (schar new-string newpos) (schar repl-str repl-pos))
 210                       (incf newpos))
 211                     (progn
 212                       (setf (schar new-string newpos) (schar string oldpos))
 213                       (incf newpos)))))
 214             new-string)))))
 215
 216
 217
 218 (defun make-usb8-array (len)
 219   (make-array len :adjustable nil
 220               :fill-pointer nil
 221               :element-type '(unsigned-byte 8)))
 222
 223 (defun usb8-array-to-string (vec)
 224   (let* ((len (length vec))
 225          (str (make-string len)))
 226     (declare (fixnum len)
 227              (simple-string str)
 228              (optimize (speed 3)))
 229     (dotimes (i len)
 230       (declare (fixnum i))
 231       (setf (schar str i) (code-char (aref vec i))))
 232     str))
 233
 234 (defun string-to-usb8-array (str)
 235   (let* ((len (length str))
 236          (vec (make-usb8-array len)))
 237     (declare (fixnum len)
 238              (type (array fixnum (*)) vec)
 239              (optimize (speed 3)))
 240     (dotimes (i len)
 241       (declare (fixnum i))
 242       (setf (aref vec i) (char-code (schar str i))))
 243     vec))
 244