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