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