;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: strings.lisp,v 1.44 2003/06/17 13:56:38 kevin Exp $
+;;;; $Id: strings.lisp,v 1.45 2003/06/20 08:35:22 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(declare (type (integer 0 15) n))
(schar +hex-chars+ n))
+(defconstant +char-code-0+ (char-code #\0))
+(defconstant +char-code-upper-a+ (char-code #\A))
+(declaim (type fixnum +char-code-0+ +char-code-upper-a+))
+
+(defun charhex (ch)
+ "convert hex character to decimal"
+ (let ((code (char-code (char-upcase ch))))
+ (declare (fixnum ch))
+ (if (>= code +char-code-upper-a+)
+ (+ 10 (- code +char-code-upper-a+))
+ (- code +char-code-0+))))
+
(defun escape-uri-field (query)
"Escape non-alphanumeric characters for URI fields"
(declare (simple-string query)
(setf (schar str dpos) (hexchar (logand c 15))))
(setf (schar str dpos) ch)))))
+(defun unescape-uri-field (query)
+ "Unescape non-alphanumeric characters for URI fields"
+ (declare (simple-string query)
+ (optimize (speed 3) (safety 0) (space 0)))
+ (do* ((count (count-string-char query #\%))
+ (len (length query))
+ (new-len (- len (* 2 count)))
+ (str (make-string new-len))
+ (spos 0 (1+ spos))
+ (dpos 0 (1+ dpos)))
+ ((= spos len) str)
+ (declare (fixnum count len new-len spos dpos)
+ (simple-string str))
+ (let ((ch (schar query spos)))
+ (if (char= #\% ch)
+ (let ((c1 (charhex (schar query (1+ spos))))
+ (c2 (charhex (schar query (+ spos 2)))))
+ (declare (fixnum c1 c2))
+ (setf (schar str dpos)
+ (code-char (logior c2 (ash c1 4))))
+ (incf spos 2))
+ (setf (schar str dpos) ch)))))
+
+
(defconstant +char-code-a+ (char-code #\a))
(defun random-string (&optional (len 10))
"Returns a random lower-case string."
(declare (optimize (speed 3)))
(let ((s (make-string len)))
- (declare (simple-string s)
- (dotimes (i len s)
- (setf (schar s i) (code-char (+ +code-char-a+ (random 26))))))))
+ (declare (simple-string s))
+ (dotimes (i len s)
+ (setf (schar s i)
+ (code-char (+ +char-code-a+ (random 26)))))))
(defun first-char (s)
(let ((len (length s)))
(when (plusp len))
(schar s (1- len)))))
+
+(defun ensure-string (v)
+ (typecase v
+ (string v)
+ (character (string v))
+ (symbol (symbol-name v))
+ (otherwise (write-to-string v))))