From 72b483ebb9fd0f02acb1b20ef14ee8bac845eca8 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Thu, 12 Jun 2003 11:10:38 +0000 Subject: [PATCH] r5097: *** empty log message *** --- package.lisp | 4 +++- strings.lisp | 33 ++++++++++++++++++++++++--------- tests.lisp | 31 ++++++++++++++++++------------- web-utils.lisp | 32 ++++++++++++++++++++++++++++++-- 4 files changed, 75 insertions(+), 25 deletions(-) diff --git a/package.lisp b/package.lisp index a4011d7..684de10 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.36 2003/06/12 02:38:39 kevin Exp $ +;;;; $Id: package.lisp,v 1.37 2003/06/12 11:10:38 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -48,6 +48,7 @@ #:fast-string-search #:string-to-list-skip-delimiter #:string-starts-with + #:count-string-char #:flatten @@ -155,6 +156,7 @@ #:*standard-xhtml-header* #:*standard-xml-header* #:user-agent-ie-p + #:decode-uri-query-string ;; From xml-utils #:wrap-with-xml diff --git a/strings.lisp b/strings.lisp index 5343f31..efce498 100644 --- a/strings.lisp +++ b/strings.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: strings.lisp,v 1.37 2003/06/12 02:38:39 kevin Exp $ +;;;; $Id: strings.lisp,v 1.38 2003/06/12 11:10:38 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -168,23 +168,25 @@ (null (find-if #'not-whitespace? str)))) (defun replaced-string-length (str repl-alist) - (declare (simple-string str)) - (let* ((orig-len (length str)) - (new-len orig-len)) + (declare (simple-string str) (declare (fixnum orig-len new-len)) - (dotimes (i orig-len) - (declare (fixnum i)) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((i 0 (1+ i)) + (orig-len (length str)) + (new-len orig-len)) + ((= i orig-len) new-len) + (declare (fixnum i orig-len new-len)) (let* ((c (char str i)) (match (assoc c repl-alist :test #'char=))) (declare (character c)) (when match - (incf new-len (1- (length (cdr match))))))) - new-len)) + (incf new-len (1- (length (cdr match)))))))) (defun substitute-chars-strings (str repl-alist) "Replace all instances of a chars with a string. repl-alist is an assoc list of characters and replacement strings." - (declare (simple-string str)) + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) (do* ((orig-len (length str)) (new-string (make-string (replaced-string-length str repl-alist))) (spos 0 (1+ spos)) @@ -336,3 +338,16 @@ Leading zeros are present." (defun string-starts-with (start str) (and (>= (length str) (length start)) (string-equal start str :end2 (length start)))) + +(defun count-string-char (s c) + "Return a count of the number of times a character appears in a string" + (declare (simple-string s) + (character c) + (optimize (speed 3) (safety 0))) + (do ((len (length s)) + (i 0 (1+ i)) + (count 0)) + ((= i len) count) + (declare (fixnum i len count)) + (when (char= (schar s i) c) + (incf count)))) diff --git a/tests.lisp b/tests.lisp index d61d439..b419fed 100644 --- a/tests.lisp +++ b/tests.lisp @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; -;;;; $Id: tests.lisp,v 1.17 2003/06/07 05:45:14 kevin Exp $ +;;;; $Id: tests.lisp,v 1.18 2003/06/12 11:10:38 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -102,10 +102,6 @@ (xml-tag-contents "tag1" "Test") nil nil nil) -(deftest pxml.1o - (kmrcl::xml-tag-contents-old "tag1" "Test") - nil nil) - (deftest pxml.2 (xml-tag-contents "tag" "Test") "Test" 15 nil) @@ -162,6 +158,17 @@ (deftest stlsd.9 (string-to-list-skip-delimiter "ab,,c,," #\,) ("ab" "c")) (deftest stlsd.10 (string-to-list-skip-delimiter " ab") ("ab")) +(deftest csc.1 (count-string-char "" #\a) 0) +(deftest csc.2 (count-string-char "abc" #\d) 0) +(deftest csc.3 (count-string-char "abc" #\b) 1) +(deftest csc.4 (count-string-char "abcb" #\b) 2) + +(deftest duqs.1 (decode-uri-query-string "") "") +(deftest duqs.2 (decode-uri-query-string "abc") "abc") +(deftest duqs.3 (decode-uri-query-string "abc+") "abc ") +(deftest duqs.4 (decode-uri-query-string "abc+d") "abc d") +(deftest duqs.5 (decode-uri-query-string "abc%20d") "abc d") + ;;; MOP Testing (eval-when (:compile-toplevel :load-toplevel :execute) @@ -170,35 +177,33 @@ #+kmrtest-mop (progn + (makunbound 'credit-rating) + (makunbound 'monitored-credit-rating) + (defclass credit-rating () ((level :attributes (date-set time-set)) (id :attributes (person-setting))) (:metaclass attributes-class)) - (defparameter cr nil) (defclass monitored-credit-rating (credit-rating) ((level :attributes (last-checked interval date-set)) (cc :initarg :cc) (id :attributes (verified))) (:metaclass attributes-class)) - (defparameter mcr (make-instance 'monitored-credit-rating)) (deftest attrib.mop.1 - (progn - (setq cr (make-instance 'credit-rating)) + (let ((cr (make-instance 'credit-rating))) (slot-attribute cr 'level 'date-set)) nil) (deftest attrib.mop.2 - (progn - (setq cr (make-instance 'credit-rating)) + (let ((cr (make-instance 'credit-rating))) (setf (slot-attribute cr 'level 'date-set) "12/15/1990") (slot-attribute cr 'level 'date-set)) "12/15/1990") (deftest attrib.mop.3 - (progn - (setq mcr (make-instance 'monitored-credit-rating)) + (let ((mcr (make-instance 'monitored-credit-rating))) (setf (slot-attribute mcr 'level 'date-set) "01/05/2002") (slot-attribute mcr 'level 'date-set)) "01/05/2002") diff --git a/web-utils.lisp b/web-utils.lisp index 1c475a8..56afffd 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.11 2003/06/12 02:38:39 kevin Exp $ +;;;; $Id: web-utils.lisp,v 1.12 2003/06/12 11:10:38 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -22,7 +22,7 @@ ;;; HTML/XML constants (defvar *standard-xml-header* - #.(format nil "~%~%~%")) + #.(format nil "~%")) (defvar *standard-html-header* "") @@ -82,3 +82,31 @@ amp (car var) "=" (cadr var)))) (rest vars)))) "")))) + +(defun decode-uri-query-string (s) + "Decode a URI query string field" + (declare (simple-string s) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((old-len (length s)) + (new-len (- old-len (* 2 (count-string-char s #\%)))) + (new (make-string new-len)) + (p-old 0) + (p-new 0 (1+ p-new))) + ((= p-new new-len) new) + (declare (simple-string new) + (fixnum p-old p-new old-len new-len)) + (let ((c (schar s p-old))) + (when (char= c #\+) + (setq c #\space)) + (case c + (#\% + (unless (>= old-len (+ p-old 3)) + (error "#\% not followed by enough characters")) + (setf (schar new p-new) + (code-char + (parse-integer (subseq s (1+ p-old) (+ p-old 3)) + :radix 16))) + (incf p-old 3)) + (t + (setf (schar new p-new) c) + (incf p-old)))))) -- 2.34.1