From 6729a4cf6ca2361b36a8ada705e7325b62c2fe54 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 15 Jun 2003 07:48:30 +0000 Subject: [PATCH] r5126: *** empty log message *** --- package.lisp | 6 ++++- strings.lisp | 59 +++++++++++++++++++++++++++++++++++++++++++++++++- tests.lisp | 11 +++++++++- web-utils.lisp | 4 ++-- 4 files changed, 75 insertions(+), 5 deletions(-) diff --git a/package.lisp b/package.lisp index 73926dd..7499e25 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.38 2003/06/14 23:24:31 kevin Exp $ +;;;; $Id: package.lisp,v 1.39 2003/06/15 07:48:30 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -42,6 +42,7 @@ #:position-char #:position-not-char #:delimited-string-to-list + #:string-delimited-string-to-list #:list-to-delimited-string #:prefixed-fixnum-string #:integer-string @@ -50,6 +51,9 @@ #:string-starts-with #:count-string-char #:count-string-char-if + #:hexchar + #:escape-uri-field + #:non-alphanumericp #:flatten diff --git a/strings.lisp b/strings.lisp index f71c137..bf10d05 100644 --- a/strings.lisp +++ b/strings.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: strings.lisp,v 1.40 2003/06/14 23:24:31 kevin Exp $ +;;;; $Id: strings.lisp,v 1.41 2003/06/15 07:48:30 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -318,6 +318,26 @@ Leading zeros are present." (unless (char= (schar str (+ i pos)) (schar substr i)) (return nil))))) +(defun string-delimited-string-to-list (str substr) + "splits a string delimited by substr into a list of strings" + #+ignore + (declare (simple-string str substr) + (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))) + (do* ((substr-len (length substr)) + (strlen (length str)) + (output '()) + (pos 0) + (end (fast-string-search substr str substr-len pos strlen) + (fast-string-search substr str substr-len pos strlen))) + ((null end) + (when (< pos strlen) + (push (subseq str pos) output)) + (nreverse output)) + (declare (fixnum strlen substr-len pos) + (type (or fixnum null) end)) + (push (subseq str pos end) output) + (setq pos (+ end substr-len)))) + (defun string-to-list-skip-delimiter (str &optional (delim #\space)) "Return a list of strings, delimited by spaces, skipping spaces." (declare (simple-string str) @@ -364,3 +384,40 @@ for characters in a string" (declare (fixnum i len count)) (when (funcall pred (schar s i)) (incf count)))) + + +;;; URL Encoding + +(defun non-alphanumericp (ch) + (not (alphanumericp ch))) + +(defvar +hex-chars+ "0123456789ABCDEF") +(declaim (type (simple-array character 16) +hex-chars+)) + +(defun hexchar (n) + (declare (type (integer 0 15) n)) + (aref +hex-chars+ n)) + +(defun escape-uri-field (query) + "Escape non-alphanumeric characters for URI fields" + (declare (simple-string query) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((count (count-string-char-if #'non-alphanumericp 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 (non-alphanumericp ch) + (let ((c (char-code ch))) + (setf (schar str dpos) #\%) + (incf dpos) + (setf (schar str dpos) (hexchar (logand (ash c -4) 15))) + (incf dpos) + (setf (schar str dpos) (hexchar (logand c 15)))) + (setf (schar str dpos) ch))))) + diff --git a/tests.lisp b/tests.lisp index b419fed..0fbbff6 100644 --- a/tests.lisp +++ b/tests.lisp @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; -;;;; $Id: tests.lisp,v 1.18 2003/06/12 11:10:38 kevin Exp $ +;;;; $Id: tests.lisp,v 1.19 2003/06/15 07:48:30 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -55,6 +55,15 @@ (deftest str.24 (delimited-string-to-list "ab|" #\|) ("ab" "")) (deftest str.25 (delimited-string-to-list "ab|" #\| t) ("ab")) +(deftest sdstl.1 (string-delimited-string-to-list "ab|cd|ef" "|a") + ("ab|cd|ef")) +(deftest sdstl.2 (string-delimited-string-to-list "ab|cd|ef" "|") + ("ab" "cd" "ef")) +(deftest sdstl.3 (string-delimited-string-to-list "ab|cd|ef" "cd") + ("ab|" "|ef")) +(deftest sdstl.4 (string-delimited-string-to-list "ab|cd|ef" "ab") + ("" "|cd|ef")) + (deftest apsl.1 (append-sublists '((a b) (c d))) (a b c d)) (deftest apsl.2 (append-sublists nil) nil) (deftest apsl.3 (append-sublists '((a b))) (a b)) diff --git a/web-utils.lisp b/web-utils.lisp index 56afffd..1473a1d 100644 --- a/web-utils.lisp +++ b/web-utils.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: web-utils.lisp,v 1.12 2003/06/12 11:10:38 kevin Exp $ +;;;; $Id: web-utils.lisp,v 1.13 2003/06/15 07:48:30 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -27,7 +27,7 @@ (defvar *standard-html-header* "") (defvar *standard-xhtml-header* - #.(format nil "~%")) + #.(format nil "~%")) ;;; User agent functions -- 2.34.1