Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[297218]: generate-page.lisp Maximize Restore History

Download this file

generate-page.lisp    77 lines (67 with data), 3.0 kB

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
(use-package :cl-ppcre)
(defmacro push-end (elt list)
`(setf ,list (nconc ,list (list ,elt))))
(defparameter *pages* nil)
(defmacro define-page (keyword title name body-fun &key (index-order :middle))
`(progn
(setf *pages* (remove ,keyword *pages* :key #'car))
(push-end (list ,keyword ,title ,name ',body-fun ,index-order) *pages*)))
(defparameter *sidebar-links* nil)
(defmacro define-sidebar-link (title url)
`(progn
(setf *sidebar-links* (remove ,title *sidebar-links* :key #'car))
(push-end (list ,title ,url) *sidebar-links*)))
(defparameter *root*
(if *load-truename*
(make-pathname :directory (pathname-directory *load-truename*))
(if (boundp '*root*)
(symbol-value '*root*)
nil)))
(defun page-link (key)
(concatenate 'string (third (assoc key *pages*)) ".html"))
(defun wrap-page-body-fun (title body-fun)
`(:|html|
(:|head|
(:|title| ,(format nil "~A - Steel Bank Common Lisp" title))
((:|link| :|rel| "stylesheet" :|type| "text/css" :|href| "sbcl.css")))
(:|body|
((:|div| :|class| "header")
(:|h1| "Steel Bank Common Lisp"))
((:|div| :|class| "sidebar")
(:|ul|
,@(loop for i in (remove :top *pages* :key #'fifth :test-not #'eq)
collect `(:|li|
((:|a| :|href| ,(page-link (car i)))
,(second i))))
,@(loop for i in (remove :middle *pages* :key #'fifth :test-not #'eq)
collect `(:|li|
((:|a| :|href| ,(page-link (car i)))
,(second i))))
,@(loop for i in *sidebar-links*
collect `(:|li|
((:|a| :|href| ,(second i))
,(first i))))
,@(loop for i in (remove :bottom *pages* :key #'fifth :test-not #'eq)
collect `(:|li|
((:|a| :|href| ,(page-link (car i)))
,(second i))))
)
((:|a| :|href| "http://sourceforge.net/" :|class| "no-highlight")
((:|img| :|src| "http://sourceforge.net/sflogo.php?group_id=1373"
:|width| "88" :|height| "31" :|border| "0" :|alt| "SourceForge Logo"))))
((:|div| :|class| "body-contents")
(:|h1| ,title)
,@(funcall body-fun)))))
(defun generate-pages ()
(loop for (keyword title fname body-fun) in *pages*
do (let ((file-name (merge-pathnames (make-pathname :type "html")
(merge-pathnames fname *root*))))
(with-open-file (f file-name :direction :output :if-exists :supersede)
(write-string "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>" f)
(terpri f)
(write-string "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" f)
(terpri f)
(write-string
(s-xml:print-xml-string
(wrap-page-body-fun title body-fun)
:pretty nil) f)))))