X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=www-image.el;h=bc727c832b99ddb94cb38ae766fbdead3b76a579;hb=436f286b7e31ca5a78194655d9b99786fdc539d6;hp=21b1e26ece6c05201f8be37c0a6cb92bdebc59d6;hpb=a5313c4cc45df1efc25a740c61437d1b18b01d1f;p=elisp%2Falbum.git diff --git a/www-image.el b/www-image.el index 21b1e26..bc727c8 100644 --- a/www-image.el +++ b/www-image.el @@ -1,189 +1,389 @@ -(defun www-image-make-spec-by-width (width limit spec-name) - (when (> width limit) - (let ((percent (floor (/ (* limit 100.0) width)))) - (vector percent spec-name - (/ (* width percent) 100.0) - (/ (* height percent) 100.0))))) - -(defun www-image-make-spec-by-height (height limit spec-name) - (when (> height limit) - (let ((percent (floor (/ (* limit 100.0) height)))) - (vector percent spec-name - (/ (* width percent) 100.0) - (/ (* height percent) 100.0))))) - -(defun www-image-write-html (dest-dir - prev-file file next-file - prev-grade grade next-grade) +;;; 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)) - - (if prev-file - (insert (format "" prev-file))) - (insert "[Previous]") - (if prev-file - (insert "")) - (insert "\n") - - (if next-file - (insert (format "" next-file))) - (insert "[Next]") - (if next-file - (insert "")) - (insert "\n") - - (if prev-grade - (insert (format "" - prev-grade - file))) - (insert "[Smaller]") - (if prev-grade - (insert "")) - (insert "\n") - - (if next-grade - (insert (format "" - next-grade - file))) - (insert "[Larger]") - (if next-grade - (insert "")) - (insert "\n") - - (insert " + ;; (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 "

") - (insert "") - (insert (format " $\"%s\"$ " file file)) - (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 " -") - (unless (file-exists-p - (expand-file-name (symbol-name grade) dest-dir)) - (make-directory - (expand-file-name (symbol-name grade) dest-dir))) - (write-region (point-min)(point-max) - (expand-file-name - (concat file ".html") - (expand-file-name (symbol-name grade) - dest-dir))))) - -(defun www-image-convert-images (dest-dir - prev-file file next-file) - (let* ((ret - (with-temp-buffer - (call-process "identify" nil t t file) - (goto-char (point-min)) - (and (re-search-forward " \$[0-9]+\$x\$[0-9]+\$ " nil t) - (cons (string-to-number (match-string 1)) - (string-to-number (match-string 2)))))) - (width (car ret)) - (height (cdr ret)) - prev-grade - rest dest) - (cond ((>= width height) - (when (setq ret (www-image-make-spec-by-width width 2048 'QXGA)) - (setq dest (cons ret dest))) - (when (setq ret (www-image-make-spec-by-width width 1600 'UXGA)) - (setq dest (cons ret dest))) - (when (setq ret (www-image-make-spec-by-width width 1400 'SXGA+)) - (setq dest (cons ret dest))) - (when (setq ret (www-image-make-spec-by-width width 1280 'SXGA)) - (setq dest (cons ret dest))) - (when (setq ret (www-image-make-spec-by-width width 1024 'XGA)) - (setq dest (cons ret dest))) - (when (setq ret (www-image-make-spec-by-width width 800 'SVGA)) - (setq dest (cons ret dest))) - (when (setq ret (www-image-make-spec-by-width width 640 'VGA)) - (setq dest (cons ret dest))) +")) + (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) ) - (t - (when (setq ret (www-image-make-spec-by-height height 1536 'QXGA)) - (setq dest (cons ret dest))) - (when (setq ret (www-image-make-spec-by-height height 1200 'UXGA)) - (setq dest (cons ret dest))) - (when (setq ret (www-image-make-spec-by-height height 1050 'SXGA+)) - (setq dest (cons ret dest))) - (when (setq ret (www-image-make-spec-by-height height 960 'SXGA)) - (setq dest (cons ret dest))) - (when (setq ret (www-image-make-spec-by-height height 768 'XGA)) - (setq dest (cons ret dest))) - (when (setq ret (www-image-make-spec-by-height height 600 'SVGA)) - (setq dest (cons ret dest))) - (when (setq ret (www-image-make-spec-by-height height 480 'VGA)) - (setq dest (cons ret dest))) - )) - (setq rest dest) - (while rest - (setq spec (car rest)) - (www-image-write-html dest-dir - (if prev-file - (file-name-sans-extension - (file-name-nondirectory prev-file))) - (file-name-sans-extension - (file-name-nondirectory file)) - (if next-file - (file-name-sans-extension - (file-name-nondirectory next-file))) - prev-grade - (aref spec 1) - (if (nth 1 rest) - (aref (nth 1 rest) 1))) - (call-process "convert" nil nil nil - "-resize" (format "%d%%" (aref spec 0)) - file - (expand-file-name - (concat - (file-name-sans-extension - (file-name-nondirectory file)) ".jpg") - (expand-file-name - (symbol-name (aref spec 1)) - dest-dir))) - (setq prev-grade (aref spec 1)) - (setq rest (cdr rest))) - (unless (file-exists-p - (expand-file-name "fullsize" dest-dir)) - (make-directory - (expand-file-name "fullsize" dest-dir))) - (call-process "convert" nil nil nil - file - (expand-file-name - (concat - (file-name-sans-extension - (file-name-nondirectory file)) ".jpg") - (expand-file-name "fullsize" dest-dir))) - dest)) - -(let ((rest - (append - (directory-files - "/archives/RAID2/koukotsu/TAKUHON/original/" 'full "^[^0-9].*\\.TIF$") - (directory-files - "/archives/RAID2/koukotsu/TAKUHON/original/" 'full "^[0-9].*\\.TIF$")) - ;; (directory-files - ;; "/archives/RAID2/koukotsu/TAKUHON/" t "\\.TIF$") - ) - file prev-file) - (while rest - (setq file (car rest)) - (www-image-convert-images - "/archives/RAID2/koukotsu/TAKUHON/" - prev-file file (nth 1 rest)) - (setq prev-file file - rest (cdr rest)))) + ((setq file (car (cdr (assoc "dir" params)))) + (www-image-display-thumbnails file size image-root lang) + )))) + + +(provide 'www-image) + +;;; www-image.el ends here