X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=web-utils.lisp;h=40cb04018bed71dfd1883a0c09880261a7eda2f3;hp=f8c073b43c3d1a0b7e7e682af701c540c2d48705;hb=baaf50bd67cbb36d51bfaf0b473cc914d140a41b;hpb=bb23129ae7ddabcbcb09c718545f69a52a8d1eaf diff --git a/web-utils.lisp b/web-utils.lisp index f8c073b..40cb040 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.5 2002/10/16 17:37:18 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,18 +16,28 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package :kmrcl) -(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))) +(in-package #:kmrcl) ;;; HTML/XML constants -(defvar *std-xml-header* - (format nil - "~%~%~%")) +(defvar *standard-xml-header* + #.(format nil "~%")) -(defun std-xml-header () - *std-xml-header*) +(defvar *standard-html-header* "") + +(defvar *standard-xhtml-header* + #.(format nil "~%")) + + +;;; User agent functions + +(defun user-agent-ie-p (agent) + "Takes a user-agent string and returns T for Internet Explorer." + (or (string-starts-with "Microsoft" agent) + (string-starts-with "Internet Explore" agent) + (search "Safari" agent) + (search "MSIE" agent))) ;;; URL Functions @@ -35,16 +45,79 @@ (defun base-url! (url) (setq *base-url* url)) -(defun make-url (page-name &key (base-dir *base-url*) (vars nil)) - (concatenate 'string base-dir page-name - (if vars - (string-trim-last-character - (concatenate 'string "?" - (mapcar-append-string - #'(lambda (var) - (when (and (car var) (cadr var)) - (concatenate 'string - (car var) "=" (cadr var) "&"))) - vars))) - ""))) +(defun make-url (page-name &key (base-dir *base-url*) (format :html) (vars nil)) + (let ((amp (case format + (:html + "&") + ((:xml :ie-xml) + "&")))) + (concatenate 'string + base-dir page-name + (if vars + (let ((first-var (first vars))) + (concatenate 'string + "?" (car first-var) "=" (cadr first-var) + (mapcar-append-string + #'(lambda (var) + (when (and (car var) (cadr var)) + (concatenate 'string + amp (car var) "=" (cadr var)))) + (rest vars)))) + "")))) + +(defun make-url-new (page-name &key (base-dir *base-url*) (format :html) + (vars nil)) + (let ((amp (ecase format + (:html "&") + ((:xml :ie-xml) "&")))) + (concatenate 'string + base-dir page-name + (if vars + (let ((first-var (first vars))) + (concatenate 'string + "?" (car first-var) "=" (cadr first-var) + (mapcar-append-string + #'(lambda (var) + (when (and (car var) (cadr var)) + (concatenate 'string + 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 (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)))))) +(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)))))))) + (delimited-string-to-list s #\&)))