Changeset main,5 for main/tags.lisp


Ignore:
Timestamp:
06/09/2008 09:54:47 PM (18 years ago)
Author:
David Owen <dsowen@…>
branch-nick:
tags
revision id:
dsowen@fugue88.ws-20080609215447-gufu5u9zswt1bhng
Message:
  • Added DEFTAG
  • Documented EXPAND-TAG
  • Added XML-escaping functions
  • Improved XML-escaping in RENDER-TAG
  • Fixed bug dealing with reusing data structures (changed an NCONC to an APPEND)
  • Bundled an XHTML tag which outputs the right doctype and namespace for XHTML 1.0 Strict
File:
1 edited

Legend:

Unmodified
Added
Removed

  • main/tags.lisp

    r4 r5  
    11#|
    2 Copyright (C) 2008  David Owen
     2Copyright (C) 2008  David Owen <dsowen@fugue88.ws>
    33
    44This program is free software: you can redistribute it and/or modify
    … …  
    1717
    1818(defpackage #:dso-tags
    19   (:use #:cl #:cl-ppcre)
    20   (:export #:*tag-out* #:expand-tag #:render-tag #:do-body))
     19  (:use #:cl #:cl-ppcre #:dso-util)
     20  (:export #:*tag-out* #:deftag #:expand-tag #:render-tag #:do-body #:xhtml))
    2121
    2222(in-package #:dso-tags)
     23
     24
     25
     26(let ((tbl '(("<" . "&lt;")
     27             (">" . "&gt;")
     28             ("&" . "&amp;")
     29             ("'" . "&apos;")
     30             ("\"" . "&quot;"))))
     31  (defun xml-entity (str)
     32    (let ((pair (assoc str tbl :test 'string=)))
     33      (assert pair (str) "The string ~S is not an XML entity." str)
     34      (cdr pair))))
     35
     36(flet ((f (str d1 d2 start end &rest dummy)
     37         (declare (ignore d1 d2 dummy))
     38         (xml-entity (subseq str start end))))
     39  (defun xml-escape (set str)
     40    (cl-ppcre:regex-replace-all set str #'f)))
     41
     42(defun xml-escape-pcdata (str)
     43  (xml-escape "[<>&]" str))
     44
     45(defun xml-escape-attr (str)
     46  (xml-escape "['\"]" str))
    2347
    2448
    … …  
    2953
    3054(defgeneric expand-tag (tag body &key &allow-other-keys)
     55  (:documentation
     56   "Specialize this to create your own tags.")
    3157  (:method (tag body &key)))
    3258
    … …  
    5177    (etypecase item
    5278      (string
    53        (format *tag-out* "~A" (regex-replace-all "([^ ])  ([^ ])" item "\\1&nbsp; \\2")))
     79       (format *tag-out* "~A"
     80               (regex-replace-all "([^ ])  ([^ ])"
     81                                  (xml-escape-pcdata item)
     82                                  "\\1&nbsp; \\2")))
    5483      (list
    5584       (multiple-value-bind (tag-name tag-body tag-attrs) (break-tag item)
    5685         (let ((expanded (apply 'expand-tag tag-name tag-body tag-attrs)))
    5786           (if expanded
    58                (setf body (nconc expanded body))
     87               (setf body (append expanded body))
    5988               (apply 'render-tag tag-name tag-body tag-attrs))))))))
    6089
    … …  
    6392(defun render-empty-tag (tag body args)
    6493  (assert (null body))
    65   (format *tag-out* "<~(~A~)~{ ~(~A~)='~A'~}/>" tag args))
     94  (format *tag-out* "<~(~A~)~{ ~(~A~)='~A'~} />"
     95          tag
     96          (loop for (key value) on args by #'cddr
     97             append (list key (xml-escape-attr value)))))
    6698
    6799(defun render-simple-tag (tag body args)
    68100  (if body
    69101      (progn
    70         (format *tag-out* "<~(~A~)~{ ~(~A~)='~A'~}>" tag args)
     102        (format *tag-out* "<~(~A~)~{ ~(~A~)='~A'~}>"
     103                tag
     104                (loop for (key value) on args by #'cddr
     105                   append (list key (xml-escape-attr value))))
    71106        (do-body body)
    72107        (format *tag-out* "</~(~A~)>" tag))
    … …  
    75110(defmethod render-tag (tag body &rest args &key &allow-other-keys)
    76111  (render-simple-tag tag body args))
     112
     113(defmethod render-tag ((tag (eql 'xhtml)) body &key &allow-other-keys)
     114  (format *tag-out* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"
     115    \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
     116  (call-next-method 'html body :xmlns "http://www.w3.org/1999/xhtml"))
     117
     118
     119
     120(defmacro deftag% (name (body-var &rest key-vars) &body body)
     121  `(defmethod expand-tag ((,(gensym) (eql ',name)) ,body-var &key ,@key-vars)
     122     ,@body))
     123
     124(defmacro deftag (name (body-vars &rest key-vars) &body body)
     125  (if (symbolp body-vars)
     126      `(deftag% ,name (,body-vars ,@key-vars) ,@body)
     127      (with-gensyms (b)
     128        `(deftag% ,name (,b ,@key-vars)
     129           (destructuring-bind (,@body-vars) ,b
     130             ,@body)))))
Note: See TracChangeset for help on using the changeset viewer.