www-page.el

   1 ;;; www-page.el --- Album page generator for page.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-page-coding-system
  31   (if (featurep 'chise)
  32       'utf-8-jp-er
  33     'utf-8))
  34
  35 (defvar www-page-default-base-directory
  36   "../pub/pages/")
  37
  38 (defvar www-page-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-page-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=\"page.cgi?")
 115         (insert url-dir)
 116         (insert file)
 117         (insert (format ".html.%s&size=%s\">"
 118                         (or lang 'en)
 119                         (or size 'VGA)))
 120         (insert (format "<img alt=\"%s\" src=\"page.cgi?%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-page-coding-system)
 140       (princ "Content-Type: text/html; charset=UTF-8
 141
 142 ")
 143       (princ (buffer-string))
 144       )))
 145
 146 (defun www-page-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-page-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=\"page.cgi?%s%s.html.%s&size=%s\">"
 221                           (file-name-directory file) prev-file
 222                           (or lang 'en)
 223                           size)))
 224       (cond ((eq lang 'ja)
 225              (insert "[\e$BA0\e(B]")
 226              )
 227             (t
 228              (insert "[Previous]")
 229              ))
 230       (if prev-file
 231           (insert "</a>"))
 232       (insert "\n")
 233
 234       (if next-file
 235           (insert (format "<a href=\"page.cgi?%s%s.html.%s&size=%s\">"
 236                           (file-name-directory file) next-file
 237                           (or lang 'en)
 238                           size)))
 239       (cond ((eq lang 'ja)
 240              (insert "[\e$B<!\e(B]")
 241              )
 242             (t
 243              (insert "[Next]")
 244              ))
 245       (if next-file
 246           (insert "</a>"))
 247       (insert "\n")
 248
 249       (if prev-grade
 250           (insert (format "<a href=\"page.cgi?%s.html.%s&size=%s\">"
 251                           file
 252                           (or lang 'en)
 253                           prev-grade)))
 254       (cond ((eq lang 'ja)
 255              (insert "[\e$B=L>.\e(B]")
 256              )
 257             (t
 258              (insert "[Smaller]")
 259              ))
 260       (if prev-grade
 261           (insert "</a>"))
 262       (insert "\n")
 263
 264       (if next-grade
 265           (insert (format "<a href=\"page.cgi?%s.html.%s&size=%s\">"
 266                           file
 267                           (or lang 'en)
 268                           next-grade)))
 269       (cond ((eq lang 'ja)
 270              (insert "[\e$B3HBg\e(B]")
 271              )
 272             (t
 273              (insert "[Larger]")
 274              ))
 275       (if next-grade
 276           (insert "</a>"))
 277       (insert "\n")
 278
 279       (insert "
 280 <hr>
 281 ")
 282       (if next-file
 283           (insert (format "<a href=\"page.cgi?%s%s.html.%s&size=%s\">"
 284                           (file-name-directory file) next-file
 285                           (or lang 'en)
 286                           size)))
 287       (insert (format "<img alt=\"%s\" src=\"page.cgi?%s&size=%s\">"
 288                       file file size))
 289       (if next-file
 290           (insert "</a>"))
 291       (insert "
 292 <hr>
 293
 294 ")
 295       (insert
 296        (format "<a href=\"page.cgi?%s&lang=%s&size=%s\">[index]</a>"
 297                (file-name-directory file)
 298                (or lang 'en)
 299                size))
 300       (insert "
 301 </body>
 302 </html>
 303 "))
 304     (encode-coding-region (point-min)(point-max) www-page-coding-system)
 305     (princ (buffer-string))
 306     ))
 307
 308 (defun www-page-display-image (file &optional size image-root)
 309   (setq file (expand-file-name file image-root))
 310   (let (file-dir file-name
 311         resized-file resized-dir
 312         spec)
 313     (cond
 314      (size
 315       (setq file-dir (file-name-directory file)
 316             file-name (file-name-nondirectory file))
 317       (setq resized-file
 318             (expand-file-name
 319              file-name
 320              (setq resized-dir
 321                    (expand-file-name
 322                     size file-dir))))
 323       (unless (file-exists-p resized-file)
 324         (setq size (intern size))
 325         (if (setq spec (assq size www-page-size-specs))
 326             (progn
 327               (condition-case nil
 328                   (unless (file-exists-p resized-dir)
 329                     (make-directory resized-dir))
 330                 (error nil))
 331               (call-process
 332                "convert" nil nil nil
 333                "-resize" (format "%dx%d>" (nth 1 spec)(nth 2 spec))
 334                file resized-file)
 335               )
 336           (setq resized-file file)))
 337       ;; (princ resized-file)
 338       (setq file resized-file)
 339       )
 340      (t
 341       ;; (princ file)
 342       ))
 343     (princ (format "Content-Type: %s"
 344                    (with-temp-buffer
 345                      (call-process
 346                       "file"
 347                       nil t t
 348                       "-b" "--mime" file)
 349                      (insert "\n")
 350                      (let ((coding-system-for-read 'binary)
 351                            (coding-system-for-write 'binary))
 352                        (insert-file-contents-literally file))
 353                      (buffer-string))))))
 354
 355 (defun www-page-batch-get ()
 356   ;; (set-coding-priority-list
 357   ;;  '(iso-7 iso-8-2 utf-8 big5 shift-jis
 358   ;;          iso-8-designate iso-8-1 iso-lock-shift no-conversion))
 359   ;; (set-coding-category-system 'utf-8 'utf-8-jp)
 360   (let (target params method size key image-root lang ret)
 361     (let ((rest (car command-line-args-left))
 362           arg val)
 363       (if rest
 364           (setq rest (split-string rest "&")))
 365       (setq target (car rest)
 366             rest (cdr rest))
 367       (while rest
 368         (when (and (string-match "=" (setq arg (car rest)))
 369                    (> (length (setq val (substring arg (match-end 0)))) 0))
 370           (setq key (substring arg 0 (match-beginning 0)))
 371           (set-alist 'params
 372                      key
 373                      (cons (decode-url-string val www-page-coding-system)
 374                            (cdr (assoc key params)))))
 375         (setq rest (cdr rest))))
 376     (setq method
 377           (cond
 378            ((string-match "\\.html\\(\\.\\([a-z]+\\)\\)?$" target)
 379             (setq lang (match-string 2 target))
 380             (setq target (substring target 0 (match-beginning 0)))
 381             (cond ((string= (file-name-nondirectory
 382                              ;; (substring target 0 (match-beginning 0))
 383                              target
 384                              )
 385                             "index")
 386                    (setq target (file-name-directory target))
 387                    'dir)
 388                   (t
 389                    'page))
 390             )
 391            ((or (string= (file-name-nondirectory target) "")
 392                 (null (file-name-extension target)))
 393             'dir)))
 394     ;; (setq file (car (cdr (assoc "file" params))))
 395     (setq size (car (cdr (assoc "size" params))))
 396     (if (setq ret (cdr (assoc "lang" params)))
 397         (setq lang (car ret)))
 398     (setq command-line-args-left (cdr command-line-args-left))
 399     (setq image-root (or (car command-line-args-left)
 400                          (expand-file-name
 401                           www-page-default-base-directory
 402                           default-directory)))
 403     (setq command-line-args-left (cdr command-line-args-left))
 404     (cond ((eq method 'dir)
 405            (www-page-display-thumbnails target size image-root lang)
 406            )
 407           ((eq method 'page)
 408            (www-page-display-page target size image-root lang)
 409            )
 410           (t
 411            (www-page-display-image target size image-root)
 412            )
 413           )))
 414
 415
 416 (provide 'www-page)
 417
 418 ;;; www-page.el ends here