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.24 2003/05/08 23:35:18 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 ;; From Larry Hunter with modifications
  59 (defun position-char (char string start max)
  60   (declare (optimize (speed 3) (safety 0))
  61            (fixnum start max) (simple-string string))
  62   (do* ((i start (1+ i)))
  63        ((= i max) nil)
  64     (declare (fixnum i))
  65     (when (char= char (schar string i)) (return i))))
  66
  67 (defun #-allegro  delimited-string-to-list
  68        #+allegro my-delimited-string-to-list
  69        (string &optional (separator #\space) skip-terminal)
  70   "split a string with delimiter"
  71   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
  72            (type string string)
  73            (type character separator))
  74   (do* ((len (length string))
  75         (output '())
  76         (pos 0)
  77         (end (position-char separator string pos len)
  78              (position-char separator string pos len)))
  79        ((null end)
  80         (if (< pos len)
  81             (push (subseq string pos) output)
  82             (when (or (not skip-terminal) (zerop len))
  83               (push "" output)))
  84         (nreverse output))
  85     (declare (type fixnum pos len)
  86              (type (or null fixnum) end))
  87     (push (subseq string pos end) output)
  88     (setq pos (1+ end))))
  89
  90
  91 (defun list-to-delimited-string (list &optional (separator #\space))
  92   (format nil (format nil "~~{~~A~~^~A~~}" separator) list))
  93
  94 (defun string-invert (str)
  95   "Invert case of a string"
  96   (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
  97            (simple-string str))
  98   (let ((up nil) (down nil))
  99     (block skip
 100       (loop for char of-type character across str do
 101             (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
 102                   ((lower-case-p char) (if up   (return-from skip str) (setf down t)))))
 103       (if up (string-downcase str) (string-upcase str)))))
 104
 105 (defun add-sql-quotes (s)
 106   (substitute-string-for-char s #\' "''"))
 107
 108 (defun escape-backslashes (s)
 109   (substitute-string-for-char s #\\ "\\\\"))
 110
 111 (defun substitute-string-for-char (procstr match-char subst-str)
 112   "Substitutes a string for a single matching character of a string"
 113   (substitute-chars-strings procstr (list (cons match-char subst-str))))
 114
 115 (defun string-substitute (string substring replacement-string)
 116   "String substitute by Larry Hunter. Obtained from Google"
 117   (let ((substring-length (length substring))
 118         (last-end 0)
 119         (new-string ""))
 120     (do ((next-start
 121           (search substring string)
 122           (search substring string :start2 last-end)))
 123         ((null next-start)
 124          (concatenate 'string new-string (subseq string last-end)))
 125       (setq new-string
 126         (concatenate 'string
 127           new-string
 128           (subseq string last-end next-start)
 129           replacement-string))
 130       (setq last-end (+ next-start substring-length)))))
 131
 132 (defun string-trim-last-character (s)
 133   "Return the string less the last character"
 134   (let ((len (length s)))
 135     (if (plusp len)
 136         (subseq s 0 (1- len))
 137         s)))
 138
 139 (defun nstring-trim-last-character (s)
 140   "Return the string less the last character"
 141   (let ((len (length s)))
 142     (if (plusp len)
 143         (nsubseq s 0 (1- len))
 144         s)))
 145
 146 (defun string-hash (str &optional (bitmask 65535))
 147   (let ((hash 0))
 148     (declare (fixnum hash)
 149              (simple-string str))
 150     (dotimes (i (length str))
 151       (declare (fixnum i))
 152       (setq hash (+ hash (char-code (char str i)))))
 153     (logand hash bitmask)))
 154
 155 (defun string-not-null? (str)
 156   (and str (not (zerop (length str)))))
 157
 158 (defun whitespace? (c)
 159   (declare (character c))
 160   (locally (declare (optimize (speed 3) (safety 0)))
 161     (or (char= c #\Space) (char= c #\Tab) (char= c #\Return)
 162         (char= c #\Linefeed))))
 163
 164 (defun not-whitespace? (c)
 165   (not (whitespace? c)))
 166
 167 (defun string-ws? (str)
 168   "Return t if string is all whitespace"
 169   (when (stringp str)
 170     (null (find-if #'not-whitespace? str))))
 171
 172 (defun replaced-string-length (str repl-alist)
 173   (declare (string str))
 174   (let* ((orig-len (length str))
 175          (new-len orig-len))
 176     (declare (fixnum orig-len new-len))
 177     (dotimes (i orig-len)
 178       (declare (fixnum i))
 179       (let* ((c (char str i))
 180              (match (assoc c repl-alist :test #'char=)))
 181         (declare (character c))
 182         (when match
 183           (incf new-len (1- (length (cdr match)))))))
 184     new-len))
 185
 186 (defun substitute-chars-strings (str repl-alist)
 187   "Replace all instances of a chars with a string. repl-alist is an assoc
 188 list of characters and replacement strings."
 189   (declare (simple-string str))
 190   (do* ((orig-len (length str))
 191         (new-string (make-string (replaced-string-length str repl-alist)))
 192         (spos 0 (1+ spos))
 193         (dpos 0))
 194       ((>= spos orig-len)
 195        new-string)
 196     (declare (fixnum spos dpos) (simple-string new-string))
 197     (let* ((c (char str spos))
 198            (match (assoc c repl-alist :test #'char=)))
 199       (declare (character c))
 200       (if match
 201           (let* ((subst (cdr match))
 202                  (len (length subst)))
 203             (declare (fixnum len))
 204             (dotimes (j len)
 205               (declare (fixnum j))
 206               (setf (char new-string dpos) (char subst j))
 207               (incf dpos)))
 208         (progn
 209           (setf (char new-string dpos) c)
 210           (incf dpos))))))
 211
 212 (defun escape-xml-string (string)
 213   "Escape invalid XML characters"
 214   (substitute-chars-strings
 215    string '((#\& . "&amp;") (#\> . "&gt;") (#\< . "&lt;") (#\" . "&quot;"))))
 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
 245 (defun concat-separated-strings (separator &rest lists)
 246   (format nil (format nil "~~{~~A~~^~A~~}" separator) (append-sublists lists)))
 247
 248 (defun only-null-list-elements-p (lst)
 249   (or (null lst) (every #'null lst)))
 250
 251 (defun print-separated-strings (strm separator &rest lists)
 252   (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
 253                      (compilation-speed 0)))
 254   (do* ((rest-lists lists (cdr rest-lists))
 255         (list (car rest-lists) (car rest-lists))
 256         (last-list (only-null-list-elements-p (cdr rest-lists))
 257                    (only-null-list-elements-p (cdr rest-lists))))
 258        ((null rest-lists) strm)
 259     (do* ((lst list (cdr lst))
 260           (elem (car lst) (car lst))
 261           (last-elem (null (cdr lst)) (null (cdr lst))))
 262          ((null lst))
 263       (write-string elem strm)
 264       (unless (and last-elem last-list)
 265         (write-string separator strm)))))