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.31 2003/05/16 12:50:05 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) (space 0)))
  34   (let ((n-words 0)
  35         (in-word nil))
  36     (declare (fixnum n-words))
  37     (do* ((len (length str))
  38           (i 0 (1+ i)))
  39         ((= i len) n-words)
  40       (declare (fixnum i))
  41       (let ((ch (schar str i)))
  42         (declare (character ch))
  43         (if (alphanumericp ch)
  44             (unless in-word
  45               (incf n-words)
  46               (setq in-word t))
  47           (setq in-word nil))))))
  48
  49 ;; From Larry Hunter with modifications
  50 (defun position-char (char string start max)
  51   (declare (optimize (speed 3) (safety 0) (space 0))
  52            (fixnum start max) (simple-string string))
  53   (do* ((i start (1+ i)))
  54        ((= i max) nil)
  55     (declare (fixnum i))
  56     (when (char= char (schar string i)) (return i))))
  57
  58 (defun delimited-string-to-list (string &optional (separator #\space)
  59                                                   skip-terminal)
  60   "split a string with delimiter"
  61   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
  62            (type string string)
  63            (type character separator))
  64   (do* ((len (length string))
  65         (output '())
  66         (pos 0)
  67         (end (position-char separator string pos len)
  68              (position-char separator string pos len)))
  69        ((null end)
  70         (if (< pos len)
  71             (push (subseq string pos) output)
  72             (when (or (not skip-terminal) (zerop len))
  73               (push "" output)))
  74         (nreverse output))
  75     (declare (type fixnum pos len)
  76              (type (or null fixnum) end))
  77     (push (subseq string pos end) output)
  78     (setq pos (1+ end))))
  79
  80
  81 (defun list-to-delimited-string (list &optional (separator #\space))
  82   (format nil (format nil "~~{~~A~~^~A~~}" separator) list))
  83
  84 (defun string-invert (str)
  85   "Invert case of a string"
  86   (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
  87            (simple-string str))
  88   (let ((up nil) (down nil))
  89     (block skip
  90       (loop for char of-type character across str do
  91             (cond ((upper-case-p char)
  92                    (if down (return-from skip str) (setf up t)))
  93                   ((lower-case-p char)
  94                    (if up   (return-from skip str) (setf down t)))))
  95       (if up (string-downcase str) (string-upcase str)))))
  96
  97 (defun add-sql-quotes (s)
  98   (substitute-string-for-char s #\' "''"))
  99
 100 (defun escape-backslashes (s)
 101   (substitute-string-for-char s #\\ "\\\\"))
 102
 103 (defun substitute-string-for-char (procstr match-char subst-str)
 104   "Substitutes a string for a single matching character of a string"
 105   (substitute-chars-strings procstr (list (cons match-char subst-str))))
 106
 107 (defun string-substitute (string substring replacement-string)
 108   "String substitute by Larry Hunter. Obtained from Google"
 109   (let ((substring-length (length substring))
 110         (last-end 0)
 111         (new-string ""))
 112     (do ((next-start
 113           (search substring string)
 114           (search substring string :start2 last-end)))
 115         ((null next-start)
 116          (concatenate 'string new-string (subseq string last-end)))
 117       (setq new-string
 118         (concatenate 'string
 119           new-string
 120           (subseq string last-end next-start)
 121           replacement-string))
 122       (setq last-end (+ next-start substring-length)))))
 123
 124 (defun string-trim-last-character (s)
 125   "Return the string less the last character"
 126   (let ((len (length s)))
 127     (if (plusp len)
 128         (subseq s 0 (1- len))
 129         s)))
 130
 131 (defun nstring-trim-last-character (s)
 132   "Return the string less the last character"
 133   (let ((len (length s)))
 134     (if (plusp len)
 135         (nsubseq s 0 (1- len))
 136         s)))
 137
 138 (defun string-hash (str &optional (bitmask 65535))
 139   (let ((hash 0))
 140     (declare (fixnum hash)
 141              (simple-string str))
 142     (dotimes (i (length str))
 143       (declare (fixnum i))
 144       (setq hash (+ hash (char-code (char str i)))))
 145     (logand hash bitmask)))
 146
 147 (defun string-not-null? (str)
 148   (and str (not (zerop (length str)))))
 149
 150 (defun whitespace? (c)
 151   (declare (character c))
 152   (locally (declare (optimize (speed 3) (safety 0)))
 153     (or (char= c #\Space) (char= c #\Tab) (char= c #\Return)
 154         (char= c #\Linefeed))))
 155
 156 (defun not-whitespace? (c)
 157   (not (whitespace? c)))
 158
 159 (defun string-ws? (str)
 160   "Return t if string is all whitespace"
 161   (when (stringp str)
 162     (null (find-if #'not-whitespace? str))))
 163
 164 (defun replaced-string-length (str repl-alist)
 165   (declare (string str))
 166   (let* ((orig-len (length str))
 167          (new-len orig-len))
 168     (declare (fixnum orig-len new-len))
 169     (dotimes (i orig-len)
 170       (declare (fixnum i))
 171       (let* ((c (char str i))
 172              (match (assoc c repl-alist :test #'char=)))
 173         (declare (character c))
 174         (when match
 175           (incf new-len (1- (length (cdr match)))))))
 176     new-len))
 177
 178 (defun substitute-chars-strings (str repl-alist)
 179   "Replace all instances of a chars with a string. repl-alist is an assoc
 180 list of characters and replacement strings."
 181   (declare (simple-string str))
 182   (do* ((orig-len (length str))
 183         (new-string (make-string (replaced-string-length str repl-alist)))
 184         (spos 0 (1+ spos))
 185         (dpos 0))
 186       ((>= spos orig-len)
 187        new-string)
 188     (declare (fixnum spos dpos) (simple-string new-string))
 189     (let* ((c (char str spos))
 190            (match (assoc c repl-alist :test #'char=)))
 191       (declare (character c))
 192       (if match
 193           (let* ((subst (cdr match))
 194                  (len (length subst)))
 195             (declare (fixnum len))
 196             (dotimes (j len)
 197               (declare (fixnum j))
 198               (setf (char new-string dpos) (char subst j))
 199               (incf dpos)))
 200         (progn
 201           (setf (char new-string dpos) c)
 202           (incf dpos))))))
 203
 204 (defun escape-xml-string (string)
 205   "Escape invalid XML characters"
 206   (substitute-chars-strings
 207    string '((#\& . "&amp;") (#\> . "&gt;") (#\< . "&lt;") (#\" . "&quot;"))))
 208
 209
 210 (defun make-usb8-array (len)
 211   (make-array len :adjustable nil
 212               :fill-pointer nil
 213               :element-type '(unsigned-byte 8)))
 214
 215 (defun usb8-array-to-string (vec)
 216   (let* ((len (length vec))
 217          (str (make-string len)))
 218     (declare (fixnum len)
 219              (simple-string str)
 220              (optimize (speed 3)))
 221     (dotimes (i len)
 222       (declare (fixnum i))
 223       (setf (schar str i) (code-char (aref vec i))))
 224     str))
 225
 226 (defun string-to-usb8-array (str)
 227   (let* ((len (length str))
 228          (vec (make-usb8-array len)))
 229     (declare (fixnum len)
 230              (type (array fixnum (*)) vec)
 231              (optimize (speed 3)))
 232     (dotimes (i len)
 233       (declare (fixnum i))
 234       (setf (aref vec i) (char-code (schar str i))))
 235     vec))
 236
 237 (defun concat-separated-strings (separator &rest lists)
 238   (format nil (format nil "~~{~~A~~^~A~~}" separator) (append-sublists lists)))
 239
 240 (defun only-null-list-elements-p (lst)
 241   (or (null lst) (every #'null lst)))
 242
 243 (defun print-separated-strings (strm separator &rest lists)
 244   (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
 245                      (compilation-speed 0)))
 246   (do* ((rest-lists lists (cdr rest-lists))
 247         (list (car rest-lists) (car rest-lists))
 248         (last-list (only-null-list-elements-p (cdr rest-lists))
 249                    (only-null-list-elements-p (cdr rest-lists))))
 250        ((null rest-lists) strm)
 251     (do* ((lst list (cdr lst))
 252           (elem (car lst) (car lst))
 253           (last-elem (null (cdr lst)) (null (cdr lst))))
 254          ((null lst))
 255       (write-string elem strm)
 256       (unless (and last-elem last-list)
 257         (write-string separator strm)))))
 258
 259 (defun prefixed-fixnum-string (num pchar len)
 260   "Outputs a string of LEN digit with an optional initial character PCHAR.
 261 Leading zeros are present."
 262   (declare (optimize (speed 3) (safety 0) (space 0))
 263            (type fixnum num len))
 264   (when pchar
 265     (incf len))
 266   (do* ((zero-code (char-code #\0))
 267         (result (make-string len :initial-element #\0))
 268         (minus? (minusp num))
 269         (val (if minus? (- 0 num) num) (floor (/ val 10)))
 270         (pos (1- len) (1- pos))
 271         (mod (mod val 10) (mod val 10)))
 272       ((or (zerop val) (minusp pos))
 273        (when pchar
 274          (setf (schar result 0) pchar))
 275        (when minus? (setf (schar result (if pchar 1 0)) #\-))
 276        result)
 277     (declare (fixnum val mod zero-code pos) (simple-string result))
 278     (setf (schar result pos) (code-char (+ zero-code mod)))))
 279
 280 (defun integer-string (num len)
 281   "Outputs a string of LEN digit with an optional initial character PCHAR.
 282 Leading zeros are present."
 283   (declare (optimize (speed 3) (safety 0) (space 0))
 284            (type fixnum len) (type integer num))
 285   (do* ((zero-code (char-code #\0))
 286         (result (make-string len :initial-element #\0))
 287         (minus? (minusp num))
 288         (val (if minus? (- 0 num) num) (floor (/ val 10)))
 289         (pos (1- len) (1- pos))
 290         (mod (mod val 10) (mod val 10)))
 291       ((or (zerop val) (minusp pos))
 292        (when minus? (setf (schar result (if pchar 1 0)) #\-))
 293        result)
 294     (declare (fixnum mod zero-code pos) (simple-string result) (integer val))
 295     (setf (schar result pos) (code-char (+ zero-code mod)))))