1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: web-utils.lisp
6 ;;;; Purpose: Basic web utility functions
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
12 ;;;; KMRCL users are granted the rights to distribute and use this software
13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
15 ;;;; *************************************************************************
20 ;;; HTML/XML constants
22 (defvar *standard-xml-header*
23 #.(format nil "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%"))
25 (defvar *standard-html-header* "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")
27 (defvar *standard-xhtml-header*
28 #.(format nil "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">"))
31 ;;; User agent functions
33 (defun user-agent-ie-p (agent)
34 "Takes a user-agent string and returns T for Internet Explorer."
35 (or (string-starts-with "Microsoft" agent)
36 (string-starts-with "Internet Explore" agent)
37 (search "Safari" agent)
38 (search "MSIE" agent)))
42 (defvar *base-url* "")
43 (defun base-url! (url)
44 (setq *base-url* url))
46 (defun make-url (page-name &key (base-dir *base-url*) (format :html) vars anchor)
47 (let ((amp (case format
55 (let ((first-var (first vars)))
57 "?" (car first-var) "=" (cdr first-var)
60 (when (and (car var) (cdr var))
62 amp (string-downcase (car var)) "=" (cdr var))))
66 (concatenate 'string "#" anchor)
69 (defun decode-uri-query-string (s)
70 "Decode a URI query string field"
71 (declare (simple-string s)
72 (optimize (speed 3) (safety 0) (space 0)))
73 (do* ((old-len (length s))
74 (new-len (- old-len (* 2 (the fixnum (count-string-char s #\%)))))
75 (new (make-string new-len))
78 ((= p-new new-len) new)
79 (declare (simple-string new)
80 (fixnum p-old p-new old-len new-len))
81 (let ((c (schar s p-old)))
86 (unless (>= old-len (+ p-old 3))
87 (error "#\% not followed by enough characters"))
88 (setf (schar new p-new)
90 (parse-integer (subseq s (1+ p-old) (+ p-old 3))
94 (setf (schar new p-new) c)
97 (defun split-uri-query-string (s)
100 (let ((pos (position #\= pair)))
102 (cons (subseq pair 0 pos)
103 (when (> (length pair) pos)
104 (decode-uri-query-string (subseq pair (1+ pos))))))))
105 (delimited-string-to-list s #\&)))