;;; -*-lisp-*-
;;;
;;; $Id$
;;;
;;; String utilities of various kinds
;;;
;;; (c) 2005 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(defpackage #:mdw.str
  (:use #:common-lisp #:mdw.base)
  (:export #:join-strings #:str-next-word #:str-split-words
	   #:str-beginsp #:str-endsp))
(in-package #:mdw.str)

(defun join-strings (del strs)
  "Join together the strings STRS with DEL between them.  All the arguments
   are first converted to strings, as if by `stringify'.  Otherwise, this is
   like Perl's join operator."
  (setf del (stringify del))
  (with-output-to-string (s)
    (when strs
      (loop
        (princ (stringify (pop strs)) s)
	(unless strs
	  (return))
	(princ del s)))))

(defun str-next-word (string &key quotedp start end)
  "Extract a whitespace-delimited word from STRING, returning it and the
   index to continue parsing from.  If no word is found, return nil twice.
   If QUOTEDP, then allow quoting and backslashifying; otherwise don't.  The
   START and END arguments limit the portion of the string to be processed;
   the default to 0 and nil (end of string), as usual."
  (setf-default start 0 end (length string))
  (let ((i start)
	(q nil)
	(e nil)
	(w (make-array 0
		       :element-type 'character
		       :adjustable t
		       :fill-pointer t)))
    ;;
    ;; Find the start of the next word.
    (loop
       (unless (< i end)
	 (return-from str-next-word (values nil nil)))
       (let ((ch (char string i)))
	 (unless (whitespace-char-p ch)
	   (return)))
       (incf i))
    ;;
    ;; Now pull off a word.
    (loop
       (unless (< i end)
	 (return))
       (let ((ch (char string i)))
	 (cond ((and quotedp (eql ch #\\))
		(setf e t))
	       (e
		(vector-push-extend ch w)
		(setf e nil))
	       ((eql ch q)
		(setf q nil))
	       (q
		(vector-push-extend ch w))
	       ((whitespace-char-p ch)
		(return))
	       ((not quotedp)
		(vector-push-extend ch w))
	       ((or (eql ch #\')
		    (eql ch #\"))
		(setf q ch))
	       ((eql ch #\`)
		(setf q #\'))
	       (t
		(vector-push-extend ch w))))
       (incf i))
    ;;
    ;; Skip to next word.
    (loop
       (unless (< i end)
	 (return))
       (let ((ch (char string i)))
	 (unless (whitespace-char-p ch)
	   (return)))
       (incf i))
    ;;
    ;; Done.
    (values (make-array (length w)
			:element-type 'character
			:initial-contents w)
	    i)))

(defun str-split-words (string &key quotedp start end max)
  "Break STRING into words, like str-next-word does, returning the list of
   the individual words.  If QUOTEDP, then allow quoting and backslashifying;
   otherwise don't.  No more than MAX `words' are returned: if the maximum is
   hit, then the last `word' is unbroken, and may still contain quotes and
   escape characters.  The START and END arguments limit the portion of the
   string to be processed in the usual way."
  (when (equal max 0)
    (return-from str-split-words nil))
  (let ((l nil) (n 0))
    (loop
       (multiple-value-bind
	   (word nextstart)
	   (str-next-word string
			  :quotedp quotedp
			  :start start
			  :end end)
	 (unless word
	   (return))
	 (when (and max (= (1+ n) max))
	   (push (subseq string start end) l)
	   (return))
	 (setf start nextstart)
	 (push word l)
	 (incf n)))
    (nreverse l)))

(declaim (inline str-beginsp))
(defun str-beginsp (string prefix &key (start1 0) end1 (start2 0) end2)
  "Returns true if STRING (or the appropriate substring of it) begins with
   PREFIX."
  (setf-default end1 (length string)
		end2 (length prefix))
  (let ((strlen (- end1 start1))
	(prelen (- end2 start2)))
    (and (>= strlen prelen)
	 (string= string prefix
		  :start1 start1 :end1 (+ start1 prelen)
		  :start2 start2 :end2 end2))))

(declaim (inline str-endsp))
(defun str-endsp (string suffix &key (start1 0) end1 (start2 0) end2)
  "Returns true if STRING (or the appropriate substring of it) ends with
   SUFFIX."
  (setf-default end1 (length string)
		end2 (length suffix))
  (let ((strlen (- end1 start1))
	(suflen (- end2 start2)))
    (and (>= strlen suflen)
	 (string= string suffix
		  :start1 (- end1 suflen) :end1 end1
		  :start2 start2 :end2 end2))))

;;;----- That's all, folks --------------------------------------------------