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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
;;;; -*- coding: utf-8; mode: lisp -*-
;;;; Copyright 2007, Matthias Andreas Benkard.
;;;------------------------------------------------------------------------
;;; This file is part of The Mulkblog Project.
;;;
;;; The Mulkblog Project is free software. You can redistribute it and/or
;;; modify it under the terms of the Affero General Public License as
;;; published by Affero, Inc.; either version 1 of the License, or
;;; (at your option) any later version.
;;;
;;; The Mulkblog Project is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the implied warranty
;;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the Affero General Public
;;; License in the COPYING file that comes with The Mulkblog Project; if
;;; not, write to Affero, Inc., 510 Third Street, Suite 225, San
;;; Francisco, CA 94107 USA.
;;;------------------------------------------------------------------------
(in-package #:mulk.journal)
(defun keywordify (thing)
(if (null thing)
thing
(intern (etypecase thing
(string (string-upcase thing))
(symbol (symbol-name thing)))
'#:keyword)))
(defun make-uuid ()
"Generate a version 4 UUID according to RFC 4122, section 4.4."
(format nil "~(~8,'0x-~4,'0x-~4,'0x-~2,'0x~2,'0x-~12,'0x~)"
(random #x100000000) ;; time_low
(random #x10000) ;; time_mid
(logior #b0100000000000000
(logand #b0000111111111111
(random #x10000))) ;; time_hi_and_version
(logior #b10000000
(logand #b00111111
(random #x100))) ;; clock_seq_hi_and_reserved
(random #x100) ;; clock_seq_low
(random #x1000000000000))) ;; node
(defun fixup-markdown-output (markup)
;; No, cl-markdown is certainly not perfect.
(reduce #'(lambda (string thing)
(destructuring-bind (regex . replacement)
thing
(ppcre:regex-replace-all regex
string
replacement)))
(load-time-value
(mapcar #'(lambda (thing)
(destructuring-bind (regex . replacement)
thing
(cons (ppcre:create-scanner regex) replacement)))
'(;; "<em>...</em> ." -> "<em>...</em>."
("(</[^>]*?>) \\." . "\\1.")
;; "<a ...> bla</a>" -> " <a ...>bla</a>"
("(<a [^>]*?>) " . " \\1"))))
:initial-value markup))
(defun name-of-day (day-of-week)
(case day-of-week
(0 "Montag")
(1 "Dienstag")
(2 "Mittwoch")
(3 "Donnerstag")
(4 "Freitag")
(5 "Samstag")
(6 "Sonntag")))
(defun %real-format-date (destination date-control-string universal-time
&optional (time-zone nil time-zone-supplied-p))
"Format DATE according to the description given by DATE-FORMAT-STRING.
Recognised format directives are: %day, %mon, %yr, %day-of-week, %zone,
%@day-of-week (name of day), %sec, %min, %hr, %daylight-p.
Note that you can mix FORMAT and FORMAT-DATE painlessly by calling them
after another in any arbitrary order."
(format
destination "~A"
(with-output-to-string (out)
(multiple-value-bind (sec min hr day mon yr day-of-week daylight-p zone)
(if time-zone-supplied-p
(decode-universal-time universal-time time-zone)
(decode-universal-time universal-time))
(let ((first-match-p t))
(ppcre:do-matches (start end "%[^%]*" date-control-string)
(let ((substring (subseq date-control-string start end)))
(multiple-value-bind (control value offset)
(regex-case substring
("^%day-of-week" (values "~D" day-of-week 12))
("^%@day-of-week" (values "~A"
(name-of-day day-of-week)
13))
("^%daylight-p" (values "~A" daylight-p 11))
("^%zone" (values "~D" zone 5))
("^%day" (values "~D" day 4))
("^%mon" (values "~D" mon 4))
("^%yr" (values "~D" yr 3))
("^%sec" (values "~D" sec 4))
("^%min" (values "~D" min 4))
("^%hr" (values "~D" hr 3))
("^%2day" (values "~2,'0D" day 5))
("^%2mon" (values "~2,'0D" mon 5))
("^%4yr" (values "~4,'0D" yr 4))
("^%2sec" (values "~2,'0D" sec 5))
("^%2min" (values "~2,'0D" min 5))
("^%2hr" (values "~2,'0D" hr 4)))
(when first-match-p
(format out (subseq date-control-string 0 start))
(setf first-match-p nil))
(if control
(progn
(format out control value)
(format out "~A" (subseq substring offset)))
(format out "~A" substring))))))))))
(defun compute-script-last-modified-date ()
#-clisp (get-universal-time)
#+clisp
(loop for file in (list* *script-filename* ;; journal.cgi
(remove-if-not #'(lambda (p)
(equal "lisp"
(pathname-type p)))
(list-directory *script-dir*)))
maximize (posix:file-stat-mtime (posix:file-stat file))))
(defun read-to-array (stream &key (initial-length 128))
"Read elements from a stream repeatedly until the end of file is
reached and write the results into a newly created array of the same
ELEMENT-TYPE as the stream's."
(do* ((buffer (make-array (list initial-length)
:element-type (stream-element-type stream)
:adjustable t
:fill-pointer t))
(last-unmodified (read-sequence buffer stream)
(read-sequence buffer stream :start old-length))
(read-elements last-unmodified
(- last-unmodified old-length))
(old-length initial-length length)
(length (ceiling (* 1.5 old-length))
(ceiling (* 1.5 old-length))))
((< last-unmodified old-length)
(setf (fill-pointer buffer) last-unmodified)
buffer)
(setf buffer (adjust-array buffer (list length)
:fill-pointer length))))
(defun call-with-result-cache (cache-id fun &key (younger-than nil younger-p))
(let ((cache-file (merge-pathnames (make-pathname :name (format nil
"CACHE-~A"
cache-id))
*cache-dir*)))
(if (and (directory-exists-p *cache-dir*)
(file-exists-p cache-file)
#-clisp nil
#+clisp (or (not younger-p)
(> (posix:file-stat-mtime (posix:file-stat cache-file))
younger-than)))
(with-open-file (in cache-file
:direction :input
:external-format #+clisp charset:utf-8
#+sbcl :utf-8)
(read-to-array in))
(with-open-file (out (if (directory-exists-p *cache-dir*)
cache-file
#p"/dev/null")
:direction :output
:if-exists :supersede
:external-format #+clisp charset:utf-8
#+sbcl :utf-8)
(let ((string (funcall fun)))
(princ string out)
string)))))
(defun format-date (destination date-control-string universal-time
&optional (time-zone nil time-zone-supplied-p))
(with-result-cache ((format nil "date-format-~D-~A-~A"
universal-time date-control-string time-zone)
:younger-than (compute-script-last-modified-date))
(apply #'%real-format-date
destination date-control-string universal-time
(and time-zone-supplied-p time-zone))))
(defun single-object (list &optional (errorp t))
(assert (null (cdr list)))
(when errorp
(assert (not (null list))))
(first list))
|
