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.42 2003/06/15 13:49:42 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       (if (alphanumericp (schar str i))
  42           (unless in-word
  43             (incf n-words)
  44             (setq in-word t))
  45         (setq in-word nil)))))
  46
  47 ;; From Larry Hunter with modifications
  48 (defun position-char (char string start max)
  49   (declare (optimize (speed 3) (safety 0) (space 0))
  50            (fixnum start max) (simple-string string))
  51   (do* ((i start (1+ i)))
  52        ((= i max) nil)
  53     (declare (fixnum i))
  54     (when (char= char (schar string i)) (return i))))
  55
  56 (defun position-not-char (char string start max)
  57   (declare (optimize (speed 3) (safety 0) (space 0))
  58            (fixnum start max) (simple-string string))
  59   (do* ((i start (1+ i)))
  60        ((= i max) nil)
  61     (declare (fixnum i))
  62     (when (char/= char (schar string i)) (return i))))
  63
  64 (defun delimited-string-to-list (string &optional (separator #\space)
  65                                                   skip-terminal)
  66   "split a string with delimiter"
  67   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
  68            (type string string)
  69            (type character separator))
  70   (do* ((len (length string))
  71         (output '())
  72         (pos 0)
  73         (end (position-char separator string pos len)
  74              (position-char separator string pos len)))
  75        ((null end)
  76         (if (< pos len)
  77             (push (subseq string pos) output)
  78             (when (or (not skip-terminal) (zerop len))
  79               (push "" output)))
  80         (nreverse output))
  81     (declare (type fixnum pos len)
  82              (type (or null fixnum) end))
  83     (push (subseq string pos end) output)
  84     (setq pos (1+ end))))
  85
  86
  87 (defun list-to-delimited-string (list &optional (separator " "))
  88   (format nil (concatenate 'string "~{~A~^" (string separator) "~}") list))
  89
  90 (defun string-invert (str)
  91   "Invert case of a string"
  92   (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
  93            (simple-string str))
  94   (let ((up nil) (down nil))
  95     (block skip
  96       (loop for char of-type character across str do
  97             (cond ((upper-case-p char)
  98                    (if down (return-from skip str) (setf up t)))
  99                   ((lower-case-p char)
 100                    (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 (simple-string str)
 172            (fixnum orig-len new-len)
 173            (optimize (speed 3) (safety 0) (space 0)))
 174     (do* ((i 0 (1+ i))
 175           (orig-len (length str))
 176           (new-len orig-len))
 177          ((= i orig-len) new-len)
 178       (declare (fixnum i orig-len new-len))
 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
 185 (defun substitute-chars-strings (str repl-alist)
 186   "Replace all instances of a chars with a string. repl-alist is an assoc
 187 list of characters and replacement strings."
 188   (declare (simple-string str)
 189            (optimize (speed 3) (safety 0) (space 0)))
 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                      (simple-string subst))
 205             (dotimes (j len)
 206               (declare (fixnum j))
 207               (setf (char new-string dpos) (char subst j))
 208               (incf dpos)))
 209         (progn
 210           (setf (char new-string dpos) c)
 211           (incf dpos))))))
 212
 213 (defun escape-xml-string (string)
 214   "Escape invalid XML characters"
 215   (substitute-chars-strings string '((#\& . "&amp;") (#\< . "&lt;"))))
 216
 217 (defun make-usb8-array (len)
 218   (make-array len :element-type '(unsigned-byte 8)))
 219
 220 (defun usb8-array-to-string (vec)
 221   (declare (type (simple-array (unsigned-byte 8) (*)) vec))
 222   (let* ((len (length vec))
 223          (str (make-string len)))
 224     (declare (fixnum len)
 225              (simple-string str)
 226              (optimize (speed 3)))
 227     (do ((i 0 (1+ i)))
 228         ((= i len) str)
 229       (declare (fixnum i))
 230       (setf (schar str i) (code-char (aref vec i))))))
 231
 232 (defun string-to-usb8-array (str)
 233   (declare (simple-string str))
 234   (let* ((len (length str))
 235          (vec (make-usb8-array len)))
 236     (declare (fixnum len)
 237              (type (simple-array (unsigned-byte 8) (*)) vec)
 238              (optimize (speed 3)))
 239     (do ((i 0 (1+ i)))
 240         ((= i len) vec)
 241       (declare (fixnum i))
 242       (setf (aref vec i) (char-code (schar str i))))))
 243
 244 (defun concat-separated-strings (separator &rest lists)
 245   (format nil (concatenate 'string "~{~A~^" (string separator) "~}")
 246           (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)))))
 266
 267 (defun prefixed-fixnum-string (num pchar len)
 268   "Outputs a string of LEN digit with an optional initial character PCHAR.
 269 Leading zeros are present."
 270   (declare (optimize (speed 3) (safety 0) (space 0))
 271            (type fixnum num len))
 272   (when pchar
 273     (incf len))
 274   (do* ((zero-code (char-code #\0))
 275         (result (make-string len :initial-element #\0))
 276         (minus? (minusp num))
 277         (val (if minus? (- 0 num) num) (floor (/ val 10)))
 278         (pos (1- len) (1- pos))
 279         (mod (mod val 10) (mod val 10)))
 280       ((or (zerop val) (minusp pos))
 281        (when pchar
 282          (setf (schar result 0) pchar))
 283        (when minus? (setf (schar result (if pchar 1 0)) #\-))
 284        result)
 285     (declare (fixnum val mod zero-code pos) (simple-string result))
 286     (setf (schar result pos) (code-char (+ zero-code mod)))))
 287
 288 (defun integer-string (num len)
 289   "Outputs a string of LEN digit with an optional initial character PCHAR.
 290 Leading zeros are present."
 291   (declare (optimize (speed 3) (safety 0) (space 0))
 292            (type fixnum len) (type integer num))
 293   (do* ((zero-code (char-code #\0))
 294         (result (make-string len :initial-element #\0))
 295         (minus? (minusp num))
 296         (val (if minus? (- 0 num) num) (floor (/ val 10)))
 297         (pos (1- len) (1- pos))
 298         (mod (mod val 10) (mod val 10)))
 299       ((or (zerop val) (minusp pos))
 300        (when minus? (setf (schar result 0) #\-))
 301        result)
 302     (declare (fixnum mod zero-code pos) (simple-string result) (integer val))
 303     (setf (schar result pos) (code-char (+ zero-code mod)))))
 304
 305 (defun fast-string-search (substr str substr-length startpos endpos)
 306   "Optimized search for a substring in a simple-string"
 307   (declare (simple-string substr str)
 308            (fixnum substr-length startpos endpos)
 309            (optimize (speed 3) (space 0) (safety 0)))
 310   (do* ((pos startpos (1+ pos))
 311         (lastpos (- endpos substr-length)))
 312        ((> pos lastpos) nil)
 313     (declare (fixnum pos lastpos))
 314     (do ((i 0 (1+ i)))
 315         ((= i substr-length)
 316          (return-from fast-string-search pos))
 317       (declare (fixnum i))
 318       (unless (char= (schar str (+ i pos)) (schar substr i))
 319         (return nil)))))
 320
 321 (defun string-delimited-string-to-list (str substr)
 322   "splits a string delimited by substr into a list of strings"
 323   #+ignore
 324   (declare (simple-string str substr)
 325            (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
 326   (do* ((substr-len (length substr))
 327         (strlen (length str))
 328         (output '())
 329         (pos 0)
 330         (end (fast-string-search substr str substr-len pos strlen)
 331              (fast-string-search substr str substr-len pos strlen)))
 332        ((null end)
 333         (when (< pos strlen)
 334           (push (subseq str pos) output))
 335         (nreverse output))
 336     (declare (fixnum strlen substr-len pos)
 337              (type (or fixnum null) end))
 338     (push (subseq str pos end) output)
 339     (setq pos (+ end substr-len))))
 340
 341 (defun string-to-list-skip-delimiter (str &optional (delim #\space))
 342   "Return a list of strings, delimited by spaces, skipping spaces."
 343   (declare (simple-string str)
 344            (optimize (speed 0) (space 0) (safety 0)))
 345   (do* ((results '())
 346         (end (length str))
 347         (i (position-not-char delim str 0 end)
 348            (position-not-char delim str j end))
 349         (j (when i (position-char delim str i end))
 350            (when i (position-char delim str i end))))
 351        ((or (null i) (null j))
 352         (when (and i (< i end))
 353           (push (subseq str i end) results))
 354         (nreverse results))
 355     (declare (fixnum i j end))
 356     (push (subseq str i j) results)))
 357
 358 (defun string-starts-with (start str)
 359   (and (>= (length str) (length start))
 360        (string-equal start str :end2 (length start))))
 361
 362 (defun count-string-char (s c)
 363   "Return a count of the number of times a character appears in a string"
 364   (declare (simple-string s)
 365            (character c)
 366            (optimize (speed 3) (safety 0)))
 367   (do ((len (length s))
 368        (i 0 (1+ i))
 369        (count 0))
 370       ((= i len) count)
 371     (declare (fixnum i len count))
 372     (when (char= (schar s i) c)
 373       (incf count))))
 374
 375 (defun count-string-char-if (pred s)
 376   "Return a count of the number of times a predicate is true
 377 for characters in a string"
 378   (declare (simple-string s)
 379            (optimize (speed 3) (safety 0) (space 0)))
 380   (do ((len (length s))
 381        (i 0 (1+ i))
 382        (count 0))
 383       ((= i len) count)
 384     (declare (fixnum i len count))
 385     (when (funcall pred (schar s i))
 386       (incf count))))
 387
 388
 389 ;;; URL Encoding
 390
 391 (defun non-alphanumericp (ch)
 392   (not (alphanumericp ch)))
 393
 394 (defvar +hex-chars+ "0123456789ABCDEF")
 395 (declaim (type simple-string +hex-chars+))
 396
 397 (defun hexchar (n)
 398   (declare (type (integer 0 15) n))
 399   (schar +hex-chars+ n))
 400
 401 (defun escape-uri-field (query)
 402   "Escape non-alphanumeric characters for URI fields"
 403   (declare (simple-string query)
 404            (optimize (speed 3) (safety 0) (space 0)))
 405   (do* ((count (count-string-char-if #'non-alphanumericp query))
 406         (len (length query))
 407         (new-len (+ len (* 2 count)))
 408         (str (make-string new-len))
 409         (spos 0 (1+ spos))
 410         (dpos 0 (1+ dpos)))
 411       ((= spos len) str)
 412     (declare (fixnum count len new-len spos dpos)
 413              (simple-string str))
 414     (let ((ch (schar query spos)))
 415       (if (non-alphanumericp ch)
 416           (let ((c (char-code ch)))
 417             (setf (schar str dpos) #\%)
 418             (incf dpos)
 419             (setf (schar str dpos) (hexchar (logand (ash c -4) 15)))
 420             (incf dpos)
 421             (setf (schar str dpos) (hexchar (logand c 15))))
 422         (setf (schar str dpos) ch)))))
 423