X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=web-utils.lisp;h=d22e7b98fcfe49b2612ca4a8551f92a4653080d7;hp=cc8f52aa0c6327c9522731bbd1218d767d5a1b3f;hb=54cd6cb1b9550ac2310e2c6dffc9cdecd2bdccd3;hpb=c42a864dc07721a3e9504094b5b8095cb5f3d03f diff --git a/web-utils.lisp b/web-utils.lisp index cc8f52a..d22e7b9 100644 --- a/web-utils.lisp +++ b/web-utils.lisp @@ -7,8 +7,6 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id$ -;;;; ;;;; 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 @@ -21,7 +19,7 @@ ;;; HTML/XML constants -(defvar *standard-xml-header* +(defvar *standard-xml-header* #.(format nil "~%")) (defvar *standard-html-header* "") @@ -45,60 +43,63 @@ (defun base-url! (url) (setq *base-url* url)) -(defun make-url (page-name &key (base-dir *base-url*) (format :html) (vars nil)) +(defun make-url (page-name &key (base-dir *base-url*) (format :html) vars anchor) (let ((amp (case format - (:html - "&") - ((:xml :ie-xml) - "&")))) - (concatenate 'string + (:html + "&") + ((:xml :ie-xml) + "&")))) + (concatenate 'string base-dir page-name (if vars - (let ((first-var (first vars))) - (concatenate 'string - "?" (car first-var) "=" (cdr first-var) - (mapcar-append-string - #'(lambda (var) - (when (and (car var) (cdr var)) - (concatenate 'string - amp (car var) "=" (cdr var)))) - (rest vars)))) - "")))) + (let ((first-var (first vars))) + (concatenate 'string + "?" (car first-var) "=" (cdr first-var) + (mapcar-append-string + #'(lambda (var) + (when (and (car var) (cdr var)) + (concatenate 'string + amp (string-downcase (car var)) "=" (cdr var)))) + (rest vars)))) + "") + (if anchor + (concatenate 'string "#" anchor) + "")))) (defun decode-uri-query-string (s) "Decode a URI query string field" (declare (simple-string s) - (optimize (speed 3) (safety 0) (space 0))) + (optimize (speed 3) (safety 0) (space 0))) (do* ((old-len (length s)) - (new-len (- old-len (* 2 (the fixnum (count-string-char s #\%))))) - (new (make-string new-len)) - (p-old 0) - (p-new 0 (1+ p-new))) + (new-len (- old-len (* 2 (the fixnum (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)))))) + (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)))))) (defun split-uri-query-string (s) (mapcar (lambda (pair) (let ((pos (position #\= pair))) (when pos - (cons (subseq pair 0 pos) - (when (> (length pair) pos) - (decode-uri-query-string (subseq pair (1+ pos)))))))) + (cons (subseq pair 0 pos) + (when (> (length pair) pos) + (decode-uri-query-string (subseq pair (1+ pos)))))))) (delimited-string-to-list s #\&)))