-(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 (file-base grade
- prev-file next-file
- prev-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
+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
+ \"http://www.w3.org/TR/html4/loose.dtd\">\n")
+ (insert "<html")
+ (if lang
+ (insert (format " lang=\"%s\"" lang)))
+ (insert ">\n")
+ (insert "<head>\n")
+ (insert (format "<title>%s</title>\n" title))
+ (insert "</head>\n")
+ (insert "<body>\n")
+ (insert (format "<h1>%s</h1>\n" title))
+
+ (insert "
+<hr>
+")
+ (dolist (image-file source-images)
+ (setq file (file-name-nondirectory image-file))
+ (insert "<a href=\"image.cgi?page=")
+ (insert url-dir)
+ (insert file)
+ (insert (format "&size=%s&lang=%s\">"
+ (or size 'VGA)
+ (or lang 'en)))
+ (insert (format "<img alt=\"%s\" src=\"image.cgi?file=%s%s&size=thumbnail\">"
+ file url-dir file))
+ (insert "</a>\n"))
+
+ (when note
+ (insert "<p>")
+ (insert note))
+
+ (insert "
+
+<hr>
+")
+ (if parent-url
+ (insert (format "[<a href=\"%s\">Return</a>]\n" parent-url)))
+
+ (insert "
+</body>
+</html>
+")
+ (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
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
\"http://www.w3.org/TR/html4/loose.dtd\">\n")
+ (insert "<html")
+ (if lang
+ (insert (format " lang=\"%s\"" lang)))
+ (insert " />\n")
(insert "<head>\n")
- (insert (format "<title>%s</title>\n"
- (file-name-nondirectory file-base)))
+ (insert (format "<title>%s</title>\n" file))
(insert "</head>\n")
(insert "<body>\n")
- (insert (format "<h1>%s</h1>\n"
- (file-name-nondirectory file-base)))
-
- (if prev-file
- (insert (format "<a href=\"%s.html\">"
- (file-name-sans-extension
- (file-name-nondirectory prev-file)))))
- (insert "[Previous]")
- (if prev-file
- (insert "</a>"))
- (insert "\n")
-
- (if next-file
- (insert (format "<a href=\"%s.html\">"
- (file-name-sans-extension
- (file-name-nondirectory next-file)))))
- (insert "[Next]")
- (if next-file
- (insert "</a>"))
- (insert "\n")
-
- (if prev-grade
- (insert (format "<a href=\"../%s/%s.html\">"
- prev-grade
- (file-name-nondirectory file-base))))
- (insert "[Smaller]")
- (if prev-grade
- (insert "</a>"))
- (insert "\n")
-
- (if next-grade
- (insert (format "<a href=\"../%s/%s.html\">"
- next-grade
- (file-name-nondirectory file-base))))
- (insert "[Larger]")
- (if next-grade
- (insert "</a>"))
- (insert "\n")
-
- (insert "
+ ;; (insert (format "<h1>%s</h1>\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 "<a href=\"image.cgi?page=%s%s&size=%s&lang=%s\">"
+ (file-name-directory file) prev-file size
+ (or lang 'en))))
+ (cond ((eq lang 'ja)
+ (insert "[\e$BA0\e(B]")
+ )
+ (t
+ (insert "[Previous]")
+ ))
+ (if prev-file
+ (insert "</a>"))
+ (insert "\n")
+
+ (if next-file
+ (insert (format "<a href=\"image.cgi?page=%s%s&size=%s&lang=%s\">"
+ (file-name-directory file) next-file size
+ (or lang 'en))))
+ (cond ((eq lang 'ja)
+ (insert "[\e$B<!\e(B]")
+ )
+ (t
+ (insert "[Next]")
+ ))
+ (if next-file
+ (insert "</a>"))
+ (insert "\n")
+
+ (if prev-grade
+ (insert (format "<a href=\"image.cgi?page=%s&size=%s&lang=%s\">"
+ file prev-grade
+ (or lang 'en))))
+ (cond ((eq lang 'ja)
+ (insert "[\e$B=L>.\e(B]")
+ )
+ (t
+ (insert "[Smaller]")
+ ))
+ (if prev-grade
+ (insert "</a>"))
+ (insert "\n")
+
+ (if next-grade
+ (insert (format "<a href=\"image.cgi?page=%s&size=%s&lang=%s\">"
+ file next-grade
+ (or lang 'en))))
+ (cond ((eq lang 'ja)
+ (insert "[\e$B3HBg\e(B]")
+ )
+ (t
+ (insert "[Larger]")
+ ))
+ (if next-grade
+ (insert "</a>"))
+ (insert "\n")
+
+ (insert "
<hr>
")
- (insert "<a href=\"")
- (insert
- (if next-grade
- (format "../%s/%s.html"
- next-grade
- (file-name-nondirectory file-base))
- (concat "../fullsize/"
- (file-name-nondirectory file-base) ".jpg")))
- (insert "\">")
- (insert (format "<img alt=\"%s\" src=\"%s.jpg\">"
- (file-name-nondirectory file-base)
- (file-name-nondirectory file-base)))
- (insert "</a>
-
+ (if next-file
+ (insert (format "<a href=\"image.cgi?page=%s%s&size=%s&lang=%s\">"
+ (file-name-directory file) next-file size
+ (or lang 'en))))
+ (insert (format "<img alt=\"%s\" src=\"image.cgi?file=%s&size=%s\">"
+ file file size))
+ (if next-file
+ (insert "</a>"))
+ (insert "
<hr>
+")
+ (insert
+ (format "<a href=\"image.cgi?dir=%s&size=%s&lang=%s\">[index]</a>"
+ (file-name-directory file) size (or lang 'en)))
+ (insert "
</body>
</html>
-")
- (unless (file-exists-p
- (expand-file-name (symbol-name grade)
- (file-name-directory file-base)))
- (make-directory
- (expand-file-name (symbol-name grade)
- (file-name-directory file-base))))
- (write-region (point-min)(point-max)
- (format "%s%s/%s.html"
- (file-name-directory file-base)
- grade
- (file-name-nondirectory file-base)))))
-
-(defun www-image-convert-images (filename &optional prev-file next-file)
- (let* ((ret
- (with-temp-buffer
- (call-process "identify" nil t t filename)
- (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 (file-name-sans-extension filename)
- (aref spec 1)
- prev-file next-file
- prev-grade
- (if (nth 1 rest)
- (aref (nth 1 rest) 1)))
- (call-process "convert" nil nil nil
- "-resize" (format "%d%%" (aref spec 0))
- filename
- (format "%s/%s/%s.jpg"
- (file-name-directory filename)
- (aref spec 1)
- (file-name-sans-extension
- (file-name-nondirectory filename))))
- (setq prev-grade (aref spec 1))
- (setq rest (cdr rest)))
- (unless (file-exists-p
- (expand-file-name "fullsize"
- (file-name-directory filename)))
- (make-directory
- (expand-file-name "fullsize"
- (file-name-directory filename))))
- (call-process "convert" nil nil nil
- filename
- (format "%s/fullsize/%s.jpg"
- (file-name-directory filename)
- (file-name-sans-extension
- (file-name-nondirectory filename))))
- dest))
-
-(let ((rest
- (append
- (directory-files
- "/archives/RAID2/koukotsu/TAKUHON/" t "^[^0-9].*\\.TIF$")
- (directory-files
- "/archives/RAID2/koukotsu/TAKUHON/" t "^[0-9].*\\.TIF$"))
- ;; (directory-files
- ;; "/archives/RAID2/koukotsu/TAKUHON/" t "\\.TIF$")
- )
- file prev-file)
- (while rest
- (setq file (car rest))
- (www-image-convert-images file prev-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
projects / elisp / album.git / blobdiff