From: tomo Date: Wed, 17 May 2006 06:49:07 +0000 (+0000) Subject: New file. X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=96e8bf58d9421aace1d0cbf18646f7bd1c7224c9;p=elisp%2Falbum.git New file. --- diff --git a/www-image.el b/www-image.el new file mode 100644 index 0000000..63695f1 --- /dev/null +++ b/www-image.el @@ -0,0 +1,376 @@ +;;; 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-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)) + (unless title + (setq title + (file-name-nondirectory + (substring url-dir 0 (1- (length 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) + (when (setq source-images (assq 'files params)) + (setq source-images (cdr source-images))) + (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")) + (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 + "../data/photo/" + 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