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.17 2003/05/04 14:52:10 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 #+excl
  48 (defun delimited-string-to-list (string &optional (separator #\space))
  49   (excl:delimited-string-to-list string separator))
  50
  51 #-excl
  52 (defun delimited-string-to-list (sequence &optional (separator #\space))
  53   "Split a string by a delimitor"
  54   (loop
  55       with start = 0
  56       for end = (position separator sequence :start start)
  57       collect (subseq sequence start end)
  58       until (null end)
  59       do
  60     (setf start (1+ end))))
  61
  62 (defun ndelimited-string-to-list (sequence &optional (separator #\space))
  63   "Split a string by a delimitor"
  64   (loop
  65       with start = 0
  66       for end = (position separator sequence :start start)
  67       collect (nsubseq sequence start end)
  68       until (null end)
  69       do
  70     (setf start (1+ end))))
  71
  72 #+excl
  73 (defun list-to-delimited-string (list &optional (separator #\space))
  74   (excl:list-to-delimited-string list separator))
  75
  76 #-excl
  77 (defun list-to-delimited-string (list &optional (separator #\space))
  78   (if (consp list)
  79       (let ((fmt (format nil "~~A~~{~A~~A~~}" separator)))
  80         (format nil fmt (first list) (rest list)))
  81       ""))
  82
  83 (defun string-invert (str)
  84   "Invert case of a string"
  85   (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
  86            (simple-string str))
  87   (let ((up nil) (down nil))
  88     (block skip
  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)))))
  93
  94 (defun add-sql-quotes (s)
  95   (substitute-string-for-char s #\' "''"))
  96
  97 (defun escape-backslashes (s)
  98   (substitute-string-for-char s #\\ "\\\\"))
  99
 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))))
 103
 104 (defun string-substitute (string substring replacement-string)
 105   "String substitute by Larry Hunter. Obtained from Google"
 106   (let ((substring-length (length substring))
 107         (last-end 0)
 108         (new-string ""))
 109     (do ((next-start
 110           (search substring string)
 111           (search substring string :start2 last-end)))
 112         ((null next-start)
 113          (concatenate 'string new-string (subseq string last-end)))
 114       (setq new-string
 115         (concatenate 'string
 116           new-string
 117           (subseq string last-end next-start)
 118           replacement-string))
 119       (setq last-end (+ next-start substring-length)))))
 120
 121 (defun string-trim-last-character (s)
 122   "Return the string less the last character"
 123   (let ((len (length s)))
 124     (if (plusp len)
 125         (subseq s 0 (1- len))
 126         s)))
 127
 128 (defun nstring-trim-last-character (s)
 129   "Return the string less the last character"
 130   (let ((len (length s)))
 131     (if (plusp len)
 132         (nsubseq s 0 (1- len))
 133         s)))
 134
 135 (defun string-hash (str &optional (bitmask 65535))
 136   (let ((hash 0))
 137     (declare (fixnum hash)
 138              (simple-string str))
 139     (dotimes (i (length str))
 140       (declare (fixnum i))
 141       (setq hash (+ hash (char-code (char str i)))))
 142     (logand hash bitmask)))
 143
 144 (defun string-not-null? (str)
 145   (and str (not (zerop (length str)))))
 146
 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))))
 152
 153 (defun not-whitespace? (c)
 154   (not (whitespace? c)))
 155
 156 (defun string-ws? (str)
 157   "Return t if string is all whitespace"
 158   (when (stringp str)
 159     (null (find-if #'not-whitespace? str))))
 160
 161 (defun replaced-string-length (str repl-alist)
 162   (declare (string str))
 163   (let* ((orig-len (length str))
 164          (new-len orig-len))
 165     (declare (fixnum orig-len new-len))
 166     (dotimes (i orig-len)
 167       (declare (fixnum i))
 168       (let* ((c (char str i))
 169              (match (assoc c repl-alist :test #'char=)))
 170         (declare (character c))
 171         (when match
 172           (incf new-len (1- (length (cdr match)))))))
 173     new-len))
 174
 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)))
 181         (spos 0 (1+ spos))
 182         (dpos 0))
 183       ((>= spos orig-len)
 184        new-string)
 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))
 189       (if match
 190           (let* ((subst (cdr match))
 191                  (len (length subst)))
 192             (declare (fixnum len))
 193             (dotimes (j len)
 194               (declare (fixnum j))
 195               (setf (char new-string dpos) (char subst j))
 196               (incf dpos)))
 197         (progn
 198           (setf (char new-string dpos) c)
 199           (incf dpos))))))
 200
 201 (defun escape-xml-string (string)
 202   "Escape invalid XML characters"
 203   (substitute-chars-strings
 204    string '((#\& . "&amp;") (#\> . "&gt;") (#\< . "&lt;") (#\" . "&quot;"))))
 205
 206
 207 (defun make-usb8-array (len)
 208   (make-array len :adjustable nil
 209               :fill-pointer nil
 210               :element-type '(unsigned-byte 8)))
 211
 212 (defun usb8-array-to-string (vec)
 213   (let* ((len (length vec))
 214          (str (make-string len)))
 215     (declare (fixnum len)
 216              (simple-string str)
 217              (optimize (speed 3)))
 218     (dotimes (i len)
 219       (declare (fixnum i))
 220       (setf (schar str i) (code-char (aref vec i))))
 221     str))
 222
 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)))
 229     (dotimes (i len)
 230       (declare (fixnum i))
 231       (setf (aref vec i) (char-code (schar str i))))
 232     vec))
 233