src/my-html.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Html generator helper
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software
  22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23 ;;;
  24 ;;; --------------------------------------------------------------------------
  25
  26
  27
  28 (in-package :common-lisp-user)
  29
  30 (defpackage :my-html
  31   (:use :common-lisp :tools)
  32   (:export :insert-html-doctype
  33            :escape-html
  34            :produce-html
  35            :with-html
  36            :produce-html-string))
  37
  38 (in-package :my-html)
  39
  40
  41 (defun insert-html-doctype ()
  42   "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
  43      \"http://www.w3.org/TR/html4/transitional.dtd\">")
  44
  45
  46 (defun escape-html (string &optional (replace '((">" "&gt;") ("<" "&lt;"))))
  47   (if replace
  48       (aif (search (caar replace) string)
  49            (escape-html (concatenate 'string (subseq string 0 it)
  50                                      (cadar replace)
  51                                      (subseq string (+ it (length (caar replace)))))
  52                 replace)
  53            (escape-html string (cdr replace)))
  54       string))
  55
  56
  57
  58
  59 (defun produce-html (tree &optional (level 0) (stream *standard-output*))
  60   (cond ((listp tree)
  61          (print-space level stream)
  62          (format stream "~(<~A>~)~%" (first tree))
  63          (dolist (subtree (rest tree))
  64            (produce-html subtree (+ 2 level) stream))
  65          (print-space level stream)
  66          (format stream "~(</~A>~)~%"
  67                  (if (stringp (first tree))
  68                      (subseq (first tree) 0 (position #\Space (first tree)))
  69                      (first tree))))
  70         (t
  71          (print-space level stream)
  72          (format stream (if (stringp tree) "~A~%" "~(~A~)~%") tree))))
  73
  74
  75 (defmacro with-html ((&optional (stream t)) &rest rest)
  76   `(produce-html ',@rest 0 ,stream))
  77
  78
  79 (defun produce-html-string (tree &optional (level 0))
  80   (with-output-to-string (str)
  81     (produce-html tree level str)))
  82
  83
  84
  85
  86 (defun test1 ()
  87   (produce-html `(html
  88                   (head
  89                    (title "Plop"))
  90                   (body
  91                    (h1 "A title")
  92                    (h2 "plop")
  93                    Plop ,(+ 2 2)
  94                    ,(format nil "Plip=~A" (+ 3 5))
  95                    ("a href=\"index.html\"" index)
  96                    (ul
  97                     (li "toto")
  98                     (li "klm"))))))
  99
 100
 101 (defun test2 ()
 102   (with-html ()
 103     (html
 104      (head
 105       (title "Plop"))
 106      "<img src=\"toto.png\">"
 107      (body
 108       (h1 "Un titre")
 109       (h2 "plop")
 110       (ul
 111        (li "toto")
 112        (li "klm"))))))
 113
 114
 115 (defun test3 ()
 116   (produce-html-string `(html
 117                          (head
 118                           (title "Plop"))
 119                          (body
 120                           (h1 "A title")
 121                           (h2 plop)
 122                           Plop ,(+ 2 2)
 123                           ,(format nil "Plip=~A" (+ 3 5))
 124                           |Foo Bar Baz|
 125                           ("a href=\"index.html\"" Index)
 126                           (ul
 127                            (li "toto")
 128                            (li "klm"))))
 129                        10))
 130
 131
 132
 133
 134