X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=web-utils.lisp;h=1614fe4fa33703501a03bdf859596db8b5474159;hb=4a5b626f01db51b02f969adb33ddad6aa9ee303a;hp=4fe21b9ab7e99a5c7800e2e7b872c5ff15e0a0df;hpb=30c2e8bd2c7043d845024395e19b3030d039eae2;p=kmrcl.git diff --git a/web-utils.lisp b/web-utils.lisp index 4fe21b9..1614fe4 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.7 2002/10/16 23:34:33 kevin Exp $ +;;;; $Id: web-utils.lisp,v 1.10 2003/06/06 21:59:30 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,8 +16,7 @@ ;;;; (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 @@ -30,22 +29,57 @@ (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." + (when (or (string-equal "Microsoft" (subseq agent 0 (length "Microsoft"))) + (string-equal "Internet Explore" (subseq agent 0 (length "Internet Explore"))) + (search "MSIE" agent)) + t)) + ;;; URL Functions (defvar *base-url* "") (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)))) + ""))))