;;; www-image.el --- Album page generator for image.cgi. ;; Copyright (C) 2005,2006 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: (defvar www-image-coding-system (if (featurep 'chise) 'utf-8-jp-er 'utf-8)) (defvar www-image-default-base-directory "../pub/pictures/") (defvar www-image-size-specs '((thumbnail 160 160) (QVGA 320 240) (VGA 640 480) (SVGA 800 600) (XGA 1024 768) (WXGA 1280 768) (SXGA 1280 1024) (SXGA+ 1400 1050) (WSXGA+ 1680 1050) (UXGA 1600 1200) (WUXGA 1920 1200) (QXGA 2048 1536) (WQXGA 2560 1600) )) (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-image-display-thumbnails (url-dir &optional size image-root lang title parent-url) (setq url-dir (file-name-as-directory url-dir)) (let* ((desc-file (expand-file-name "dir.desc" (expand-file-name url-dir image-root))) (params (with-temp-buffer (when (file-exists-p desc-file) (insert-file-contents desc-file) (read (current-buffer))))) source-images file 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 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 "
") (dolist (image-file source-images) (setq file (file-name-nondirectory image-file)) (insert "" (or size 'VGA) (or lang 'en))) (insert (format "\"%s\"" file url-dir file)) (insert "\n")) (when note (insert "

") (insert note)) (insert "


") (if parent-url (insert (format "[Return]\n" parent-url))) (insert " ") (encode-coding-region (point-min)(point-max) www-image-coding-system) (princ "Content-Type: text/html; charset=UTF-8 ") (princ (buffer-string)) ))) (defun www-image-display-page (file &optional size image-root lang prev-file next-file) (if (stringp size) (setq size (intern size))) (if (stringp lang) (setq lang (intern lang))) (princ "Content-Type: text/html; charset=UTF-8 ") (with-temp-buffer (insert "\n") (insert "\n") (insert "\n") (insert (format "%s\n" file)) (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 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 (with-temp-buffer (when (file-exists-p dir-desc-file) (insert-file-contents dir-desc-file) (read (current-buffer))))) (when (setq rest (assq 'files params)) (setq rest (cdr rest))) (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))) (with-temp-buffer (insert (format "%S" params)) ;; (princ "X-XEmacs-Message: ") (write-region (point-min)(point-max) desc-file) ;; (princ "\n") )) (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-image-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)))) (if prev-file (insert (format "" (file-name-directory file) prev-file size (or lang 'en)))) (cond ((eq lang 'ja) (insert "[前]") ) (t (insert "[Previous]") )) (if prev-file (insert "")) (insert "\n") (if next-file (insert (format "" (file-name-directory file) next-file size (or lang 'en)))) (cond ((eq lang 'ja) (insert "[次]") ) (t (insert "[Next]") )) (if next-file (insert "")) (insert "\n") (if prev-grade (insert (format "" file prev-grade (or lang 'en)))) (cond ((eq lang 'ja) (insert "[縮小]") ) (t (insert "[Smaller]") )) (if prev-grade (insert "")) (insert "\n") (if next-grade (insert (format "" file next-grade (or lang 'en)))) (cond ((eq lang 'ja) (insert "[拡大]") ) (t (insert "[Larger]") )) (if next-grade (insert "")) (insert "\n") (insert "
") (if next-file (insert (format "" (file-name-directory file) next-file size (or lang 'en)))) (insert (format "\"%s\"" file file size)) (if next-file (insert "")) (insert "
") (insert (format "[index]" (file-name-directory file) size (or lang 'en))) (insert " ")) (encode-coding-region (point-min)(point-max) www-image-coding-system) (princ (buffer-string)) )) (defun www-image-display-image (file &optional size image-root) (setq file (expand-file-name file image-root)) (let (file-dir file-name resized-file resized-dir spec) (cond (size (setq file-dir (file-name-directory file) file-name (file-name-nondirectory file)) (setq resized-file (expand-file-name file-name (setq resized-dir (expand-file-name size file-dir)))) (unless (file-exists-p resized-file) (setq size (intern size)) (if (setq spec (assq size www-image-size-specs)) (progn (condition-case nil (unless (file-exists-p resized-dir) (make-directory resized-dir)) (error nil)) (call-process "convert" nil nil nil "-resize" (format "%dx%d>" (nth 1 spec)(nth 2 spec)) file resized-file) ) (setq resized-file file))) ;; (princ resized-file) (setq file resized-file) ) (t ;; (princ file) )) (princ (format "Content-Type: %s" (with-temp-buffer (call-process "file" nil t t "-b" "--mime" file) (insert "\n") (let ((coding-system-for-read 'binary) (coding-system-for-write 'binary)) (insert-file-contents-literally file)) (buffer-string)))))) (defun www-image-batch-get () ;; (set-coding-priority-list ;; '(iso-7 iso-8-2 utf-8 big5 shift-jis ;; iso-8-designate iso-8-1 iso-lock-shift no-conversion)) ;; (set-coding-category-system 'utf-8 'utf-8-jp) (let (params file size key image-root lang) (let ((rest (car command-line-args-left)) arg val) (if rest (setq rest (split-string rest "&"))) (while rest (when (and (string-match "=" (setq arg (car rest))) (> (length (setq val (substring arg (match-end 0)))) 0)) (setq key (substring arg 0 (match-beginning 0))) (set-alist 'params key (cons (decode-url-string val www-image-coding-system) (cdr (assoc key params))))) (setq rest (cdr rest)))) (setq file (car (cdr (assoc "file" params)))) (setq size (car (cdr (assoc "size" params)))) (setq lang (car (cdr (assoc "lang" params)))) (setq command-line-args-left (cdr command-line-args-left)) (setq image-root (or (car command-line-args-left) (expand-file-name www-image-default-base-directory default-directory))) (setq command-line-args-left (cdr command-line-args-left)) (cond (file (www-image-display-image file size image-root) ) ((setq file (car (cdr (assoc "page" params)))) (www-image-display-page file size image-root lang) ) ((setq file (car (cdr (assoc "dir" params)))) (www-image-display-thumbnails file size image-root lang) )))) (provide 'www-image) ;;; www-image.el ends here