")
(when (and (location entry)
(weather-directory (parent entry)))
(format s "~&~A~@[ ~A~] "
(substitute #\Space #\- (string (location entry)))
(format-weather nil
(get-weather (location entry)
(year entry)
(month entry)
(day entry)
(weather-directory
(parent entry)))
(language entry))))
(multiple-value-bind (months years)
(surrounding-months (year entry) (month entry))
(loop for y in years
for m in months
for month = (get-month (parent entry) y m (language entry))
when (first month)
do (format s "~&~A~%" (second month))))
(format s "~&
")))
(arrows)
;;
(loop for language in (language-symbols)
unless (eql language (language entry))
do (let ((e (get-entry (parent entry)
(year entry) (month entry) (day entry)
language)))
(when e
(format s "~&
~A
"
(link-to (link-name e)
(language-cleartext language))))))
;;
(format s "~&
~A
" (text entry))
(arrows)
(comment-link s entry)
(html-footer s entry)))))
(defmethod create-month-index ((blog blog) this-year this-month language)
(multiple-value-bind (months years)
(surrounding-months this-year this-month)
(format t "~&CREATE-MONTH-INDEX ~A ~A" years months)
(loop for y in years
for m in months
for month = (get-month blog y m language)
do
(unless (and month (stringp (second month)))
(when (first month)
(set-month blog y m language
(list (first month)
(with-output-to-string
(md)
(format md "~&~A ~4,'0D: "
(month-name m language)
y)
(loop for i from 1 upto (days-in-month m y)
for e = (get-entry blog y m i language)
do
(format md "~A "
(if e
(link-to (link-name
(list (local-base blog)
y m i
language
"php"))
i)
i))
finally (format md "~& "))))))))))
(defmethod create-entry ((blog blog) &rest key-args)
(set-entry blog (apply #'make-instance
'entry
:parent blog
key-args)))
(let (last-location)
(defun get-location (pics)
(let ((last-pic (car (last pics))))
(when (and last-pic
(typep last-pic 'symbol))
(setq last-location last-pic))
last-location)))
(defun get-title (pics language languages)
(let ((title (find 'title pics :key #'(lambda (x)
(typecase x
(list (car x))
(t nil))))))
(when title
(or (nth (position language languages)
(rest title))
(first (rest title))))))
(defmethod make-entry ((blog blog) y m day-contents)
(destructuring-bind (date &optional pics &rest texts)
day-contents
(let ((time (encode-universal-time 0 0 0 date m y)))
(when (> time (second (end-entries blog)))
(setf (second (end-entries blog)) time))
(when (< time (first (end-entries blog)))
(setf (first (end-entries blog)) time)))
(mapc #'(lambda (text language)
(let ((plain (to-plain-text
(substitute-tags blog text
pics
language
:synopsis t))))
(create-entry blog
:year y
:month m
:day date
:language language
:location (get-location pics)
:title (get-title pics language
(languages blog))
:original-text text
:plain-text (string-left-trim
" "
(substitute
#\Space #\Newline
plain))
:feed-text (htmlify plain)
:text
(paragraphify
(substitute-tags blog text pics
language)))))
texts
(language-symbols))))
(defmethod create-pages ((blog blog))
(dolist (file-contents (text blog))
(destructuring-bind (year month days)
file-contents
(dolist (entry days)
(make-entry blog year month entry))))
(format t "~&Pages created~%")
(loop for year from (start-year blog) to (end-year blog)
do
(loop for month from 1 to 12
do
(format t "~&Processing ~D/~D..." month year)
(loop for language in (language-symbols)
do
(loop for day from 1 to (days-in-month month year)
for entry = (get-entry blog year month day language)
do
;; (format t " ~D-~2,'0D-~2,'0D." year month day)
(when (typep entry 'entry)
(unless (previous entry)
(let ((prev (adjacent-entry blog entry :previous)))
(format t "<~A<" prev)
(when prev
(setf (previous entry) prev))
(when (typep prev 'entry)
(setf (following prev) entry))))
(unless (following entry)
(let ((foll (adjacent-entry blog entry :following)))
(format t ">~A>" foll)
(when foll
(setf (following entry) foll))
(when (typep foll 'entry)
(setf (previous foll) entry)))))))))
(format t "Done.~%"))
(defun table-cell (contents) (format nil "
~A
" contents))
(defmethod output-pages ((blog blog))
(loop for language in (language-symbols)
for lang in (language-short-symbols)
when (position language (languages *blog*))
do
(ensure-directories-exist (html-directory blog))
(with-open-file (s (format nil "~Aindex-~A.html"
(html-directory blog)
lang)
:direction :output
:if-exists :supersede)
(html-header s blog language)
;;
(loop for other-lang in (language-symbols)
when (and (position other-lang (languages *blog*))
(not (eql other-lang language)))
do
(format s "~&~A"
(language-short-symbol other-lang)
(language-cleartext other-lang)))
;;
(format s "~& ~%~A"
(img (format nil "~Aindeksi.jpg"
(string+ (local-base blog)
(pic-directory blog)))
(title blog)))
;;
(loop for year from (end-year blog) downto (start-year blog)
do
(format s "~&
")
(loop for month from 12 downto 1
for entries = (month-has-entries blog year month language)
when entries
do
(when (eql entries 'pages)
(with-open-file (page-index (format nil "~A/~A-~4,'0D-~2,'0D~A"
(html-directory blog)
language year month
(index-suffix blog))
:direction :output
:if-exists :supersede)
(format page-index "~&(~A ~4,'0D (~D"
language year month)
(loop for day from 1 upto (days-in-month month year)
when (get-entry blog year month day language)
do (format page-index " ~D" day))
(format page-index "))~%")))
(create-month-index blog year month language)
(format s "~&
~A ~A
~%"
(month-name month language)
year)
(loop for day from 1 upto (days-in-month month year)
for page = (get-entry blog year month day language)
do
(cond (page
(format s (table-cell
(link-to (page-name
(local-base blog)
year month day language "php")
day)))
(output page))
(t
(format s (table-cell day)))))
(format s "~&
~%"))
(format s "~&
")) ; year
(format s "~A"
(link-to (string+ (base-url blog)
(string-downcase language)
".xml")
(img (string+ (base-url blog) "kuvat/xml.png")
"RSS Feed"
0)))
(dolist (hook (get-hooks blog 'index))
(funcall hook s (base-url blog) language))
(html-footer s blog language))))
;;;;;;;;;;;;;;;;
(defun startup (&optional (init-file "blog.conf"))
(when (and init-file (probe-file init-file))
(load init-file))
(unless *blog*
(setq *blog* (make-instance 'blog))))
(defun meta (stream http-equiv content)
(format stream "~&~%"
http-equiv content))
(defun starts-with (string-1 string-2)
(not (mismatch string-1 string-2 :end1 (min (length string-1)
(length string-2)))))
(defmethod redirect ((blog blog))
(flet ((redirect-to (entry)
(page-name nil
(year entry) (month entry) (day entry)
(language entry) "php")))
(let ((old-file (make-pathname :directory (html-directory blog)
:name ""
:type "htaccess"))
(input-file (pathname (string+ (text-directory blog)
"htaccess")))
(new-file (pathname "/tmp/blogsym-htaccess"))
(language-indexes (mapcar #'(lambda (x)
(cons x
(format nil "RewriteRule ^~A/ "
(string-downcase x))))
(languages blog))))
(with-open-file (input input-file
:direction :input)
(with-open-file (htaccess new-file
:direction :output
:if-exists :supersede)
(loop for line = (read-line input nil)
while line
do
(cond ((starts-with line "RewriteRule ^$ ")
(format htaccess "RewriteRule ^$ ~A [R]~%"
(redirect-to (last-page blog))))
((starts-with line "RewriteRule ^index.html$ ")
(format htaccess "RewriteRule ^index.html$ ~A [R]~%"
(redirect-to (last-page blog))))
(t
(let (printed)
(dolist (lang language-indexes)
(when (starts-with line (cdr lang))
(setq printed t)
(format htaccess "~A ~A [R]~%"
(cdr lang)
(redirect-to (last-page blog
(car lang))))))
(unless printed
(format htaccess "~A~%" line))))))))
(when (probe-file old-file)
(delete-file old-file))
(rename-file new-file old-file))))
(defmethod get-pages ((blog blog) from-end language how-many)
(let (ret (counter (or how-many 1)))
(do ((year (if from-end (end-year blog) (start-year blog))
(if from-end (1- year) (1+ year))))
((if from-end
(< year (start-year blog))
(> year (end-year blog))) nil)
(do ((month (if from-end 12 1) (if from-end (1- month) (1+ month))))
((if from-end (< month 1) (> month 12)) nil)
(do ((day (if from-end (days-in-month month year) 1)
(if from-end (1- day) (1+ day))))
((if from-end (< day 1) (> day (days-in-month month year))) nil)
(let ((e (get-entry blog year month day
(or language
(default-language blog)
(first (languages blog))))))
(when e
(push e ret)
(decf counter)
(when (= 0 counter)
(return-from get-pages (nreverse ret))))))))
(nreverse ret)))
(defmethod first-pages ((blog blog) &optional language how-many)
(get-pages blog nil language how-many))
(defmethod last-pages ((blog blog) &optional language how-many)
(get-pages blog t language how-many))
(defmethod last-page ((blog blog) &optional language)
(unless language
(setq language (default-language blog)))
(unless (assoc language (slot-value blog 'last-page))
(push (cons language
(first (last-pages blog language)))
(slot-value blog 'last-page)))
(cdr (assoc language (slot-value blog 'last-page))))
(defmethod entries ((blog blog) which language &optional size)
(ecase which
(:first (first-pages blog language size))
(:last (last-pages blog language size))))
(defun rss-tag (stream indent tag text)
(let ((tag (let ((s (split (string-downcase tag) #\-)))
(string+ (first s)
(mapcar #'string-capitalize (rest s))))))
(format stream "~&~A<~A>~A"
(make-string indent :initial-element #\Space)
tag text tag)))
(defun rss-tags (stream indent &rest tags)
(loop for tag on tags by #'cddr
when (second tag)
do (rss-tag stream indent (first tag) (second tag))))
(defun publication-date (date)
(multiple-value-bind (second minute hour date month year day
daylight-saving-time-p time-zone)
(decode-universal-time date)
(format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~D ~A ~D ~2,'0D:~2,'0D:~2,'0D UT"
day date (subseq (month-name month 'english) 0 3) year
hour minute second)))
(defun positions (item seq &key max)
(loop for c = (position item seq :start (if c (1+ c) 0))
for limit = (or (not max) (>= (decf max) 0))
while (and c limit) collect c))
(defun tags (text)
(let ((open (positions #\< text))
(close (positions #\> text)))
(mapcar #'cons open close)))
(defun not-tags (text)
(let ((tags (tags text)))
(if (not tags)
nil
(append (loop for (open . close) in (tags text)
with start = 0
for end = open
collect (prog1 (cons start end)
(setf start (1+ close))))
(when (< (cdar (last tags)) (1- (length text)))
(list (cons (1+ (cdar (last tags))) nil)))))))
(defun not-char (text &optional (ch #\Newline))
;; doesn't work - leaves out stuff after last ch
(let ((pos (positions ch text)))
(loop for p in pos
with s = 0
collect (prog1 (cons s p)
(setf s (1+ p))))))
(defmacro cut-text (marker-fun text)
(let ((txt (gensym))
(pos (gensym)))
`(let* ((,txt ,text)
(,pos (funcall ,marker-fun ,txt)))
(if (not ,pos)
,txt
(loop for (start . end) in ,pos
collect (subseq ,text start end) into s
finally
(return (string+ s)))))))
(defun to-plain-text (text)
(cut-text #'not-tags text))
(defun remove-linebreaks (text)
;; doesn't work - see above
(cut-text #'not-char text))
(defmethod rss-item-title ((entry entry))
(cond ((title entry)
(title entry))
(t
(let* ((plain-text (plain-text entry))
(period (position #\. plain-text))
(comma (position #\, plain-text))
(space (nth 5 (positions #\Space plain-text :max 6)))
(len (length plain-text)))
(subseq plain-text 0 (min (or period len)
(or comma len)
(or space len)))))))
(defmethod rss (stream (blog blog) &optional language size)
(format stream "~&")
(format stream "~&~% ")
(rss-tags stream 2
'title (title blog)
'managing-editor (contact-address blog)
'link (base-url blog)
'description (title blog)
'language (string-downcase
(language-iso639 language
(nth (position language
(languages blog))
(language-variants blog))))
'pub-date (publication-date (date (last-page blog language)))
'generator (string+ *blogsym-name* " " *blogsym-version*))
(dolist (entry (entries blog :last language (or size (rss-size blog))))
(format stream "~& ")
(rss-tags stream 3
'title (rss-item-title entry)
'link (link-name entry t)
'pub-date (publication-date (date entry))
'description (feed-text entry))
(format stream "~& "))
(format stream "~& ~%"))
(defun create (&optional force)
(unless (and *blog* (not force))
(startup))
(create-pages *blog*)
(output-pages *blog*)
(ensure-directories-exist (html-directory *blog*))
(redirect *blog*)
(loop for language in (language-symbols)
when (position language (languages *blog*))
do
(format t "~&RSS: ~A..." language)
(with-open-file (xml (format nil "~A/~A.xml"
(html-directory *blog*)
(string-downcase language))
:direction :output
:if-exists :supersede)
(rss xml *blog* language))))
;; EOF