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.2 2002/11/04 18:02:13 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 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
  22
  23 ;;; Strings
  24
  25 (defmacro string-append (outputstr &rest args)
  26   `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
  27
  28 (defmacro string-field-append (outputstr &rest args)
  29   `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
  30
  31 (defun list-to-string (lst)
  32   "Converts a list to a string, doesn't include any delimiters between elements"
  33   (format nil "~{~A~}" lst))
  34
  35 (defun count-string-words (str)
  36   (declare (simple-string str)
  37            (optimize (speed 3) (safety 0)))
  38   (let ((n-words 0)
  39         (in-word nil))
  40     (declare (fixnum n-words))
  41     (dotimes (i (length str))
  42       (let ((ch (char str i)))
  43         (declare (character ch))
  44         (if (alphanumericp ch)
  45             (unless in-word
  46               (incf n-words)
  47               (setq in-word t))
  48           (setq in-word nil))))
  49     n-words))
  50
  51 #+excl
  52 (defun delimited-string-to-list (string &optional (separator #\space))
  53   (excl:delimited-string-to-list string separator))
  54
  55 #-excl
  56 (defun delimited-string-to-list (sequence &optional (separator #\space))
  57   "Split a string by a delimitor"
  58   (loop
  59       with start = 0
  60       for end = (position separator sequence :start start)
  61       collect (subseq sequence start end)
  62       until (null end)
  63       do
  64     (setf start (1+ end))))
  65
  66 #+excl
  67 (defun list-to-delimited-string (list &optional (separator #\space))
  68   (excl:list-to-delimited-string list separator))
  69
  70 #-excl
  71 (defun list-to-delimited-string (list &optional (separator #\space))
  72   (let ((output (when list (format nil "~A" (car list)))))
  73     (dolist (obj (rest list))
  74       (setq output (concatenate 'string output
  75                                 (format nil "~A" separator)
  76                                 (format nil "~A" obj))))
  77     output))
  78
  79 (defun string-invert (str)
  80   "Invert case of a string"
  81   (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
  82            (simple-string str))
  83   (let ((up nil) (down nil))
  84     (block skip
  85       (loop for char of-type character across str do
  86             (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
  87                   ((lower-case-p char) (if up   (return-from skip str) (setf down t)))))
  88       (if up (string-downcase str) (string-upcase str)))))
  89
  90 (defun add-sql-quotes (s)
  91   (substitute-string-for-char s #\' "''"))
  92
  93 (defun escape-backslashes (s)
  94   (substitute-string-for-char s #\\ "\\\\"))
  95
  96 (defun substitute-string-for-char (procstr match-char subst-str)
  97   "Substitutes a string for a single matching character of a string"
  98   (let ((pos (position match-char procstr)))
  99     (if pos
 100         (concatenate 'string
 101           (subseq procstr 0 pos) subst-str
 102           (substitute-string-for-char (subseq procstr (1+ pos)) match-char subst-str))
 103       procstr)))
 104
 105 (defun string-substitute (string substring replacement-string)
 106   "String substitute by Larry Hunter. Obtained from Google"
 107   (let ((substring-length (length substring))
 108         (last-end 0)
 109         (new-string ""))
 110     (do ((next-start
 111           (search substring string)
 112           (search substring string :start2 last-end)))
 113         ((null next-start)
 114          (concatenate 'string new-string (subseq string last-end)))
 115       (setq new-string
 116         (concatenate 'string
 117           new-string
 118           (subseq string last-end next-start)
 119           replacement-string))
 120       (setq last-end (+ next-start substring-length)))))
 121
 122
 123 (defun string-trim-last-character (s)
 124 "Return the string less the last character"
 125   (subseq s 0 (1- (length s))))
 126
 127 (defun string-hash (str &optional (bitmask 65535))
 128   (let ((hash 0))
 129     (declare (fixnum hash)
 130              (simple-string str))
 131     (dotimes (i (length str))
 132       (declare (fixnum i))
 133       (setq hash (+ hash (char-code (char str i)))))
 134     (logand hash bitmask)))
 135
 136 (defun string-not-null? (str)
 137   (and str (not (zerop (length str)))))
 138
 139 (defun whitespace? (c)
 140   (declare (character c))
 141   (declare (optimize (speed 3) (safety 0)))
 142   (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) (char= c #\Linefeed)))
 143
 144 (defun not-whitespace? (c)
 145   (not (whitespace? c)))
 146
 147 (defun string-ws? (str)
 148   "Return t if string is all whitespace"
 149   (when (stringp str)
 150     (null (find-if #'not-whitespace? str))))
 151