;;; www-page.el --- Album page generator for page.cgi.
;; Copyright (C) 2005,2006,2007 MORIOKA Tomohiko
;; Keywords: Photo, image, album, HTML, WWW
;; This file is part of Album.
;; Album is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; Album 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 GNU
;; General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; It requires `convert' and `identify' of ImageMagick.
;;; Code:
(defconst www-page-version "0.4")
(defvar www-page-coding-system
(if (featurep 'chise)
'utf-8-jp-er
'utf-8))
(defvar www-page-default-base-directory
"../pub/pages/")
(defvar www-page-size-specs
'((thumbnail 160 160)
(QVGA 320 240)
(VGA 640 480)
(SVGA 800 600)
(XGA 1024 768)
(WXGA 1280 800)
(SXGA 1280 1024)
(SXGA+ 1400 1050)
(WSXGA+ 1680 1050)
(UXGA 1600 1200)
(WUXGA 1920 1200)
(QXGA 2048 1536)
(WQXGA 2560 1600)
(original nil nil)
))
(defun decode-url-string (string &optional coding-system)
(if (> (length string) 0)
(let ((i 0)
dest)
(while (string-match "%\\([0-9A-F][0-9A-F]\\)" string i)
(setq dest (concat dest
(substring string i (match-beginning 0))
(char-to-string
(int-char
(string-to-int (match-string 1 string) 16))))
i (match-end 0)))
(decode-coding-string
(concat dest (substring string i))
coding-system))))
(defun www-page-open-dir (url-dir &optional image-root)
(let* ((path (expand-file-name url-dir image-root))
(desc-file (expand-file-name "dir.desc" path)))
(cons (cons 'location path)
(with-temp-buffer
(when (file-exists-p desc-file)
(insert-file-contents desc-file)
(read (current-buffer)))))))
(defun www-page-directory-image-files (url-dir image-root)
(let (source-images)
(dolist (file (directory-files (expand-file-name url-dir image-root)
nil "\\.\\(jpg\\|JPG\\)$" nil t))
(unless (string-match "_[^_]+GA[^_]*$"
(file-name-sans-extension file))
(setq source-images (cons file source-images))))
(nreverse source-images)))
(defun www-page-display-dir (url-dir &optional size image-root
lang title parent-url hide-cgi
pivot-mode)
(setq url-dir (file-name-as-directory url-dir))
(princ "Content-Type: text/html; charset=UTF-8
")
(let* ((params (www-page-open-dir url-dir image-root))
source-images ref-images
file i ref-file prev-file next-file file-desc
note)
(when (setq title (assq 'title params))
(setq title (cdr title)))
(unless title
(setq title
(file-name-nondirectory
(substring url-dir 0 (1- (length url-dir))))))
(when (setq source-images (assq 'files params))
(setq source-images (cdr source-images)))
(when (setq ref-images (assq 'refs params))
(setq ref-images (cdr ref-images)))
(unless (or source-images ref-images)
(setq source-images
(www-page-directory-image-files url-dir image-root)))
(when (setq note (assq 'note params))
(setq note (cdr note)))
(when (setq parent-url (assq 'exit params))
(setq parent-url (cdr parent-url)))
(with-temp-buffer
(insert
"\n")
(insert "\n")
(insert "
\n")
(insert (format "%s\n" title))
(insert "\n")
(insert "\n")
(insert (format "%s
\n" title))
(insert "
")
(cond
((or (eq lang 'ja)
(string= lang "ja"))
(insert
"[Note] サムネイルをクリックすると大きな画像が表示されます
")
)
(t
(insert (format "lang = %s
\n" lang))))
(dolist (image-file source-images)
(setq file (file-name-nondirectory image-file))
(insert ""
(or lang 'en)
(or size 'VGA)
(or pivot-mode t)))
(insert (format "
")
(insert "\n"))
(setq i 1)
(while ref-images
(setq ref-file (car ref-images))
(setq next-file
(if (cdr ref-images)
(format "%d" (1+ i))))
(setq file-desc
(expand-file-name
(format "%d.desc" i)
(expand-file-name url-dir image-root)))
(unless (file-exists-p file-desc)
(with-temp-buffer
(insert "(")
(if prev-file
(insert (format "(prev-file . %S)\n " prev-file)))
;; (insert (format "(ref . \"%s%s\")\n "
;; url-dir ref-file))
(insert (format "(ref . \"%s\")\n "
ref-file))
(if next-file
(insert (format "(next-file . %S)\n " next-file)))
(insert "))\n")
(write-region (point-min)(point-max) file-desc)))
(setq file (file-name-nondirectory ref-file))
(insert ""
i
(or lang 'en)
(or size 'VGA)))
;; (insert (format "
"
;; file url-dir ref-file))
(insert (format "
"
file ref-file))
(insert "\n")
(setq prev-file (format "%d" i))
(setq i (1+ i)
ref-images (cdr ref-images)))
(when note
(insert "")
(insert note))
(insert "
")
(if parent-url
(insert (format "[Return]\n" parent-url)))
(insert
(format "
Powered by MnjAlbum WWW-Page Version %s." www-page-version))
(insert "
")
(encode-coding-region (point-min)(point-max) www-page-coding-system)
(princ (buffer-string))
)))
(defun www-page-display-page (file &optional size image-root
lang prev-file next-file hide-cgi
pivot-mode)
(if (stringp size)
(setq size (intern size)))
(if (stringp pivot-mode)
(setq pivot-mode (intern pivot-mode)))
(if (stringp lang)
(setq lang (intern lang)))
(princ "Content-Type: text/html; charset=UTF-8
")
(with-temp-buffer
(insert
"\n")
(insert "\n")
;; (insert (format "%s
\n" file))
(let* ((desc-file (expand-file-name (concat file ".desc") image-root))
(params
(with-temp-buffer
(when (file-exists-p desc-file)
(insert-file-contents desc-file)
(read (current-buffer)))))
;; dir-desc-file
image-file image-ref
prev-file next-file
prev-grade next-grade
rest spec ret)
(unless params
;; (setq dir-desc-file
;; (expand-file-name "dir.desc"
;; (expand-file-name (file-name-directory file)
;; image-root)))
(setq params
(www-page-open-dir (file-name-directory file) image-root)
;; (with-temp-buffer
;; (when (file-exists-p dir-desc-file)
;; (insert-file-contents dir-desc-file)
;; (read (current-buffer))))
)
(unless (assq 'refs params)
(if (setq rest (assq 'files params))
(setq rest (cdr rest))
(setq rest
(www-page-directory-image-files
(file-name-directory file) image-root)))
(setq ret (file-name-nondirectory file))
(while (and rest
(not (string= (car rest) ret)))
(setq prev-file (car rest)
rest (cdr rest)))
(setq next-file (car (cdr rest)))
(if prev-file
(setq params (list (cons 'prev-file prev-file))))
(if next-file
(setq params (cons (cons 'next-file next-file)
params)))
(if (file-directory-p (file-name-directory desc-file))
(with-temp-buffer
(insert (format "%S" params))
;; (princ "X-XEmacs-Message: ")
(write-region (point-min)(point-max) desc-file)
;; (princ "\n")
))))
(if (setq image-ref (assq 'ref params))
(setq image-ref (cdr image-ref))
(setq image-file file))
(if (setq prev-file (assq 'prev-file params))
(setq prev-file (cdr prev-file)))
(if (setq next-file (assq 'next-file params))
(setq next-file (cdr next-file)))
(setq rest www-page-size-specs)
(while (and rest
(setq spec (car rest))
(not (eq (car spec) size)))
(setq prev-grade (car spec)
rest (cdr rest)))
(setq next-grade (car (car (cdr rest))))
(when prev-file
(insert ""
prev-file
(or lang 'en)
size
pivot-mode))
)
(cond ((eq lang 'ja)
(insert "[前]")
)
(t
(insert "[Previous]")
))
(if prev-file
(insert ""))
(insert "\n")
(when next-file
(insert ""
next-file
(or lang 'en)
size
pivot-mode))
)
(cond ((eq lang 'ja)
(insert "[次]")
)
(t
(insert "[Next]")
))
(if next-file
(insert ""))
(insert "\n")
(when prev-grade
(insert ""
(file-name-nondirectory file)
(or lang 'en)
prev-grade
pivot-mode))
)
(cond ((eq lang 'ja)
(insert "[縮小]")
)
(t
(insert "[Smaller]")
))
(if prev-grade
(insert ""))
(insert "\n")
(when next-grade
(insert ""
(file-name-nondirectory file)
(or lang 'en)
next-grade
pivot-mode))
)
(cond ((eq lang 'ja)
(insert "[拡大]")
)
(t
(insert "[Larger]")
))
(if next-grade
(insert ""))
(insert "\n")
(insert "
")
(when next-file
(insert ""
next-file
(or lang 'en)
size
pivot-mode))
)
(cond
(image-ref
(insert
(format "
"
file image-ref size pivot-mode))
)
(t ; (file-exists-p (expand-file-name image-file image-root))
(insert (format "
"
(file-name-nondirectory image-file)
size pivot-mode))
)
(t
(insert "")
(insert (format
(cond
((eq lang 'ja)
"画像ファイル %s が見付かりません。\n")
(t
"Image file %s is not found.\n"))
file))))
(if next-file
(insert "
"))
)
(insert "
")
;; (insert
;; (format "[index]"
;; (file-name-directory file)
;; (or lang 'en)
;; size))
(insert "%s"
(or lang 'en)
size
pivot-mode
(cond ((eq lang 'ja)
"[index] に戻る")
(t
"[index]"))))
(insert
(cond ((eq lang 'ja)
"(変更した大きさは維持されます)")
(t
"")))
(insert
(format "
Powered by MnjAlbum WWW-Page Version %s." www-page-version))
(insert "