www-image.el

   1 ;;; www-image.el --- Album page generator for image.cgi.
   2
   3 ;; Copyright (C) 2005,2006 MORIOKA Tomohiko
   4
   5 ;; Keywords: Photo, image, album, HTML, WWW
   6
   7 ;; This file is part of Album.
   8
   9 ;; Album is free software; you can redistribute it and/or modify it
  10 ;; under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; Album is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; It requires `convert' and `identify' of ImageMagick.
  27
  28 ;;; Code:
  29
  30 (defvar www-image-coding-system
  31   (if (featurep 'chise)
  32       'utf-8-jp-er
  33     'utf-8))
  34
  35 (defvar www-image-default-base-directory
  36   "../pub/pictures/")
  37
  38 (defvar www-image-size-specs
  39   '((thumbnail   160  160)
  40     (QVGA        320  240)
  41     (VGA         640  480)
  42     (SVGA        800  600)
  43     (XGA        1024  768)
  44     (WXGA       1280  768)
  45     (SXGA       1280 1024)
  46     (SXGA+      1400 1050)
  47     (WSXGA+     1680 1050)
  48     (UXGA       1600 1200)
  49     (WUXGA      1920 1200)
  50     (QXGA       2048 1536)
  51     (WQXGA      2560 1600)
  52     ))
  53
  54 (defun decode-url-string (string &optional coding-system)
  55   (if (> (length string) 0)
  56       (let ((i 0)
  57             dest)
  58         (while (string-match "%\\([0-9A-F][0-9A-F]\\)" string i)
  59           (setq dest (concat dest
  60                              (substring string i (match-beginning 0))
  61                              (char-to-string
  62                               (int-char
  63                                (string-to-int (match-string 1 string) 16))))
  64                 i (match-end 0)))
  65         (decode-coding-string
  66          (concat dest (substring string i))
  67          coding-system))))
  68
  69 (defun www-image-display-thumbnails (url-dir &optional size image-root
  70                                              lang title parent-url)
  71   (setq url-dir (file-name-as-directory url-dir))
  72   (let* ((desc-file
  73           (expand-file-name "dir.desc"
  74                             (expand-file-name url-dir image-root)))
  75          (params
  76           (with-temp-buffer
  77             (when (file-exists-p desc-file)
  78               (insert-file-contents desc-file)
  79               (read (current-buffer)))))
  80          source-images
  81          file
  82          note)
  83     (when (setq title (assq 'title params))
  84       (setq title (cdr title)))
  85     (unless title
  86       (setq title
  87             (file-name-nondirectory
  88              (substring url-dir 0 (1- (length url-dir))))))
  89     (when (setq source-images (assq 'files params))
  90       (setq source-images (cdr source-images)))
  91     (when (setq note (assq 'note params))
  92       (setq note (cdr note)))
  93     (when (setq parent-url (assq 'exit params))
  94       (setq parent-url (cdr parent-url)))
  95     (with-temp-buffer
  96       (insert
  97        "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
  98             \"http://www.w3.org/TR/html4/loose.dtd\">\n")
  99       (insert "<html")
 100       (if lang
 101           (insert (format " lang=\"%s\"" lang)))
 102       (insert ">\n")
 103       (insert "<head>\n")
 104       (insert (format "<title>%s</title>\n" title))
 105       (insert "</head>\n")
 106       (insert "<body>\n")
 107       (insert (format "<h1>%s</h1>\n" title))
 108
 109       (insert "
 110 <hr>
 111 ")
 112       (dolist (image-file source-images)
 113         (setq file (file-name-nondirectory image-file))
 114         (insert "<a href=\"image.cgi?page=")
 115         (insert url-dir)
 116         (insert file)
 117         (insert (format "&size=%s&lang=%s\">"
 118                         (or size 'VGA)
 119                         (or lang 'en)))
 120         (insert (format "<img alt=\"%s\" src=\"image.cgi?file=%s%s&size=thumbnail\">"
 121                         file url-dir file))
 122         (insert "</a>\n"))
 123
 124       (when note
 125         (insert "<p>")
 126         (insert note))
 127
 128       (insert "
 129
 130 <hr>
 131 ")
 132       (if parent-url
 133           (insert (format "[<a href=\"%s\">Return</a>]\n" parent-url)))
 134
 135       (insert "
 136 </body>
 137 </html>
 138 ")
 139       (encode-coding-region (point-min)(point-max) www-image-coding-system)
 140       (princ "Content-Type: text/html; charset=UTF-8
 141
 142 ")
 143       (princ (buffer-string))
 144       )))
 145
 146 (defun www-image-display-page (file &optional size image-root
 147                                     lang prev-file next-file)
 148   (if (stringp size)
 149       (setq size (intern size)))
 150   (if (stringp lang)
 151       (setq lang (intern lang)))
 152   (princ "Content-Type: text/html; charset=UTF-8
 153
 154 ")
 155   (with-temp-buffer
 156     (insert
 157      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
 158             \"http://www.w3.org/TR/html4/loose.dtd\">\n")
 159     (insert "<html")
 160     (if lang
 161         (insert (format " lang=\"%s\"" lang)))
 162     (insert " />\n")
 163     (insert "<head>\n")
 164     (insert (format "<title>%s</title>\n" file))
 165     (insert "</head>\n")
 166     (insert "<body>\n")
 167     ;; (insert (format "<h1>%s</h1>\n" file))
 168
 169     (let* ((desc-file (expand-file-name (concat file ".desc") image-root))
 170            (params
 171             (with-temp-buffer
 172               (when (file-exists-p desc-file)
 173                 (insert-file-contents desc-file)
 174                 (read (current-buffer)))))
 175            dir-desc-file
 176            prev-file next-file
 177            prev-grade next-grade
 178            rest spec ret)
 179       (unless params
 180         (setq dir-desc-file
 181               (expand-file-name "dir.desc"
 182                                 (expand-file-name (file-name-directory file)
 183                                                   image-root)))
 184         (setq params
 185               (with-temp-buffer
 186                 (when (file-exists-p dir-desc-file)
 187                   (insert-file-contents dir-desc-file)
 188                   (read (current-buffer)))))
 189         (when (setq rest (assq 'files params))
 190           (setq rest (cdr rest)))
 191         (setq ret (file-name-nondirectory file))
 192         (while (and rest
 193                     (not (string= (car rest) ret)))
 194           (setq prev-file (car rest)
 195                 rest (cdr rest)))
 196         (setq next-file (car (cdr rest)))
 197         (if prev-file
 198             (setq params (list (cons 'prev-file prev-file))))
 199         (if next-file
 200             (setq params (cons (cons 'next-file next-file)
 201                                params)))
 202         (with-temp-buffer
 203           (insert (format "%S" params))
 204           ;; (princ "X-XEmacs-Message: ")
 205           (write-region (point-min)(point-max) desc-file)
 206           ;; (princ "\n")
 207           ))
 208       (if (setq prev-file (assq 'prev-file params))
 209           (setq prev-file (cdr prev-file)))
 210       (if (setq next-file (assq 'next-file params))
 211           (setq next-file (cdr next-file)))
 212       (setq rest www-image-size-specs)
 213       (while (and rest
 214                   (setq spec (car rest))
 215                   (not (eq (car spec) size)))
 216         (setq prev-grade (car spec)
 217               rest (cdr rest)))
 218       (setq next-grade (car (car (cdr rest))))
 219       (if prev-file
 220           (insert (format "<a href=\"image.cgi?page=%s%s&size=%s&lang=%s\">"
 221                           (file-name-directory file) prev-file size
 222                           (or lang 'en))))
 223       (cond ((eq lang 'ja)
 224              (insert "[\e$BA0\e(B]")
 225              )
 226             (t
 227              (insert "[Previous]")
 228              ))
 229       (if prev-file
 230           (insert "</a>"))
 231       (insert "\n")
 232
 233       (if next-file
 234           (insert (format "<a href=\"image.cgi?page=%s%s&size=%s&lang=%s\">"
 235                           (file-name-directory file) next-file size
 236                           (or lang 'en))))
 237       (cond ((eq lang 'ja)
 238              (insert "[\e$B<!\e(B]")
 239              )
 240             (t
 241              (insert "[Next]")
 242              ))
 243       (if next-file
 244           (insert "</a>"))
 245       (insert "\n")
 246
 247       (if prev-grade
 248           (insert (format "<a href=\"image.cgi?page=%s&size=%s&lang=%s\">"
 249                           file prev-grade
 250                           (or lang 'en))))
 251       (cond ((eq lang 'ja)
 252              (insert "[\e$B=L>.\e(B]")
 253              )
 254             (t
 255              (insert "[Smaller]")
 256              ))
 257       (if prev-grade
 258           (insert "</a>"))
 259       (insert "\n")
 260
 261       (if next-grade
 262           (insert (format "<a href=\"image.cgi?page=%s&size=%s&lang=%s\">"
 263                           file next-grade
 264                           (or lang 'en))))
 265       (cond ((eq lang 'ja)
 266              (insert "[\e$B3HBg\e(B]")
 267              )
 268             (t
 269              (insert "[Larger]")
 270              ))
 271       (if next-grade
 272           (insert "</a>"))
 273       (insert "\n")
 274
 275       (insert "
 276 <hr>
 277 ")
 278       (if next-file
 279           (insert (format "<a href=\"image.cgi?page=%s%s&size=%s&lang=%s\">"
 280                           (file-name-directory file) next-file size
 281                           (or lang 'en))))
 282       (insert (format "<img alt=\"%s\" src=\"image.cgi?file=%s&size=%s\">"
 283                       file file size))
 284       (if next-file
 285           (insert "</a>"))
 286       (insert "
 287 <hr>
 288
 289 ")
 290       (insert
 291        (format "<a href=\"image.cgi?dir=%s&size=%s&lang=%s\">[index]</a>"
 292                (file-name-directory file) size (or lang 'en)))
 293       (insert "
 294 </body>
 295 </html>
 296 "))
 297     (encode-coding-region (point-min)(point-max) www-image-coding-system)
 298     (princ (buffer-string))
 299     ))
 300
 301 (defun www-image-display-image (file &optional size image-root)
 302   (setq file (expand-file-name file image-root))
 303   (let (file-dir file-name
 304         resized-file resized-dir
 305         spec)
 306     (cond
 307      (size
 308       (setq file-dir (file-name-directory file)
 309             file-name (file-name-nondirectory file))
 310       (setq resized-file
 311             (expand-file-name
 312              file-name
 313              (setq resized-dir
 314                    (expand-file-name
 315                     size file-dir))))
 316       (unless (file-exists-p resized-file)
 317         (setq size (intern size))
 318         (if (setq spec (assq size www-image-size-specs))
 319             (progn
 320               (condition-case nil
 321                   (unless (file-exists-p resized-dir)
 322                     (make-directory resized-dir))
 323                 (error nil))
 324               (call-process
 325                "convert" nil nil nil
 326                "-resize" (format "%dx%d>" (nth 1 spec)(nth 2 spec))
 327                file resized-file)
 328               )
 329           (setq resized-file file)))
 330       ;; (princ resized-file)
 331       (setq file resized-file)
 332       )
 333      (t
 334       ;; (princ file)
 335       ))
 336     (princ (format "Content-Type: %s"
 337                    (with-temp-buffer
 338                      (call-process
 339                       "file"
 340                       nil t t
 341                       "-b" "--mime" file)
 342                      (insert "\n")
 343                      (let ((coding-system-for-read 'binary)
 344                            (coding-system-for-write 'binary))
 345                        (insert-file-contents-literally file))
 346                      (buffer-string))))))
 347
 348 (defun www-image-batch-get ()
 349   ;; (set-coding-priority-list
 350   ;;  '(iso-7 iso-8-2 utf-8 big5 shift-jis
 351   ;;          iso-8-designate iso-8-1 iso-lock-shift no-conversion))
 352   ;; (set-coding-category-system 'utf-8 'utf-8-jp)
 353   (let (params file size key image-root lang)
 354     (let ((rest (car command-line-args-left))
 355           arg val)
 356       (if rest
 357           (setq rest (split-string rest "&")))
 358       (while rest
 359         (when (and (string-match "=" (setq arg (car rest)))
 360                    (> (length (setq val (substring arg (match-end 0)))) 0))
 361           (setq key (substring arg 0 (match-beginning 0)))
 362           (set-alist 'params
 363                      key
 364                      (cons (decode-url-string val www-image-coding-system)
 365                            (cdr (assoc key params)))))
 366         (setq rest (cdr rest))))
 367     (setq file (car (cdr (assoc "file" params))))
 368     (setq size (car (cdr (assoc "size" params))))
 369     (setq lang (car (cdr (assoc "lang" params))))
 370     (setq command-line-args-left (cdr command-line-args-left))
 371     (setq image-root (or (car command-line-args-left)
 372                          (expand-file-name
 373                           www-image-default-base-directory
 374                           default-directory)))
 375     (setq command-line-args-left (cdr command-line-args-left))
 376     (cond (file
 377            (www-image-display-image file size image-root)
 378            )
 379           ((setq file (car (cdr (assoc "page" params))))
 380            (www-image-display-page file size image-root lang)
 381            )
 382           ((setq file (car (cdr (assoc "dir" params))))
 383            (www-image-display-thumbnails file size image-root lang)
 384            ))))
 385
 386
 387 (provide 'www-image)
 388
 389 ;;; www-image.el ends here