New file.
authortomo <tomo>
Wed, 17 May 2006 06:49:07 +0000 (06:49 +0000)
committertomo <tomo>
Wed, 17 May 2006 06:49:07 +0000 (06:49 +0000)
www-image.el [new file with mode: 0644]

diff --git a/www-image.el b/www-image.el
new file mode 100644 (file)
index 0000000..63695f1
--- /dev/null
@@ -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
+       "<!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"))
+      (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))
+    (insert "</head>\n")
+    (insert "<body>\n")
+    ;; (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>
+")
+      (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>
+"))
+    (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