+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: strings.lisp
+;;;; Purpose: Strings utility functions for KMRCL package
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: strings.lisp,v 1.1 2002/10/12 06:10:17 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+
+(in-package :kmrcl)
+(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
+;;; Strings
+
+(defmacro string-append (outputstr &rest args)
+ `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
+
+(defmacro string-field-append (outputstr &rest args)
+ `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
+
+(defun list-to-string (lst)
+ "Converts a list to a string, doesn't include any delimiters between elements"
+ (format nil "~{~A~}" lst))
+
+(defun count-string-words (str)
+ (declare (simple-string str)
+ (optimize (speed 3) (safety 0)))
+ (let ((n-words 0)
+ (in-word nil))
+ (declare (fixnum n-words))
+ (dotimes (i (length str))
+ (let ((ch (char str i)))
+ (declare (character ch))
+ (if (alphanumericp ch)
+ (unless in-word
+ (incf n-words)
+ (setq in-word t))
+ (setq in-word nil))))
+ n-words))
+
+#+excl
+(defun delimited-string-to-list (string &optional (separator #\space))
+ (excl:delimited-string-to-list string separator))
+
+#-excl
+(defun delimited-string-to-list (sequence &optional (separator #\space))
+"Split a string by a delimitor"
+ (loop
+ with start = 0
+ for end = (position separator sequence :start start)
+ collect (subseq sequence start end)
+ until (null end)
+ do
+ (setf start (1+ end))))
+
+#+excl
+(defun list-to-delimited-string (list &optional (separator #\space))
+ (excl:list-to-delimited-string list separator))
+
+#-excl
+(defun list-to-delimited-string (list &optional (separator #\space))
+ (let ((output (when list (format nil "~A" (car list)))))
+ (dolist (obj (rest list))
+ (setq output (concatenate 'string output
+ (format nil "~A" separator)
+ (format nil "~A" obj))))
+ output))
+
+(defun string-invert (str)
+ "Invert case of a string"
+ (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
+ (simple-string str))
+ (let ((up nil) (down nil))
+ (block skip
+ (loop for char of-type character across str do
+ (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
+ ((lower-case-p char) (if up (return-from skip str) (setf down t)))))
+ (if up (string-downcase str) (string-upcase str)))))
+
+(defun add-sql-quotes (s)
+ (substitute-string-for-char s #\' "''"))
+
+(defun escape-backslashes (s)
+ (substitute-string-for-char s #\\ "\\\\"))
+
+(defun substitute-string-for-char (procstr match-char subst-str)
+"Substitutes a string for a single matching character of a string"
+ (let ((pos (position match-char procstr)))
+ (if pos
+ (concatenate 'string
+ (subseq procstr 0 pos) subst-str
+ (substitute-string-for-char (subseq procstr (1+ pos)) match-char subst-str))
+ procstr)))
+
+(defun string-substitute (string substring replacement-string)
+ "String substitute by Larry Hunter. Obtained from Google"
+ (let ((substring-length (length substring))
+ (last-end 0)
+ (new-string ""))
+ (do ((next-start
+ (search substring string)
+ (search substring string :start2 last-end)))
+ ((null next-start)
+ (concatenate 'string new-string (subseq string last-end)))
+ (setq new-string
+ (concatenate 'string
+ new-string
+ (subseq string last-end next-start)
+ replacement-string))
+ (setq last-end (+ next-start substring-length)))))
+
+
+(defun string-trim-last-character (s)
+"Return the string less the last character"
+ (subseq s 0 (1- (length s))))
+
+(defun string-hash (str &optional (bitmask 65535))
+ (let ((hash 0))
+ (declare (fixnum hash)
+ (simple-string str))
+ (dotimes (i (length str))
+ (declare (fixnum i))
+ (setq hash (+ hash (char-code (char str i)))))
+ (logand hash bitmask)))
+
+(defun string-not-null? (str)
+ (and str (not (zerop (length str)))))
+
+(defun whitespace? (c)
+ (declare (character c))
+ (declare (optimize (speed 3) (safety 0)))
+ (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) (char= c #\Linefeed)))
+
+(defun not-whitespace? (c)
+ (not (whitespace? c)))
+
+(defun string-ws? (str)
+ "Return t if string is all whitespace"
+ (when (stringp str)
+ (null (find-if #'not-whitespace? str))))
+