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   (princ "Content-Type: text/html; charset=UTF-8
  73
  74 ")
  75   (let* ((desc-file
  76           (expand-file-name "dir.desc"
  77                             (expand-file-name url-dir image-root)))
  78          (params
  79           (with-temp-buffer
  80             (when (file-exists-p desc-file)
  81               (insert-file-contents desc-file)
  82               (read (current-buffer)))))
  83          source-images ref-images
  84          file i ref-file prev-file next-file file-desc
  85          note)
  86     (when (setq title (assq 'title params))
  87       (setq title (cdr title)))
  88     (unless title
  89       (setq title
  90             (file-name-nondirectory
  91              (substring url-dir 0 (1- (length url-dir))))))
  92     (when (setq source-images (assq 'files params))
  93       (setq source-images (cdr source-images)))
  94     (when (setq ref-images (assq 'refs params))
  95       (setq ref-images (cdr ref-images)))
  96     (when (setq note (assq 'note params))
  97       (setq note (cdr note)))
  98     (when (setq parent-url (assq 'exit params))
  99       (setq parent-url (cdr parent-url)))
 100     (with-temp-buffer
 101       (insert
 102        "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
 103             \"http://www.w3.org/TR/html4/loose.dtd\">\n")
 104       (insert "<html")
 105       (if lang
 106           (insert (format " lang=\"%s\"" lang)))
 107       (insert ">\n")
 108       (insert "<head>\n")
 109       (insert (format "<title>%s</title>\n" title))
 110       (insert "</head>\n")
 111       (insert "<body>\n")
 112       (insert (format "<h1>%s</h1>\n" title))
 113
 114       (insert "
 115 <hr>
 116 ")
 117       (dolist (image-file source-images)
 118         (setq file (file-name-nondirectory image-file))
 119         (insert "<a href=\"page.cgi?")
 120         (insert url-dir)
 121         (insert file)
 122         (insert (format ".html.%s&size=%s\">"
 123                         (or lang 'en)
 124                         (or size 'VGA)))
 125         (insert (format "<img alt=\"%s\" src=\"page.cgi?%s%s&size=thumbnail\">"
 126                         file url-dir file))
 127         (insert "</a>\n"))
 128
 129       (setq i 1)
 130       (while ref-images
 131         (setq ref-file (car ref-images))
 132         (setq next-file
 133               (if (cdr ref-images)
 134                   (format "%d" (1+ i))))
 135         (setq file-desc
 136               (expand-file-name
 137                (format "%d.desc" i)
 138                (expand-file-name url-dir image-root)))
 139         (unless (file-exists-p file-desc)
 140           (with-temp-buffer
 141             (insert "(")
 142             (if prev-file
 143                 (insert (format "(prev-file . %S)\n " prev-file)))
 144             ;; (insert (format "(ref . \"%s%s\")\n "
 145             ;;                 url-dir ref-file))
 146             (insert (format "(ref . \"%s\")\n "
 147                             ref-file))
 148             (if next-file
 149                 (insert (format "(next-file . %S)\n " next-file)))
 150             (insert "))\n")
 151             (write-region (point-min)(point-max) file-desc)))
 152         (setq file (file-name-nondirectory ref-file))
 153         (insert "<a href=\"page.cgi?")
 154         (insert url-dir)
 155         (insert (format "%d.html.%s&size=%s\">"
 156                         i
 157                         (or lang 'en)
 158                         (or size 'VGA)))
 159         ;; (insert (format "<img alt=\"%s\" src=\"page.cgi?%s%s&size=thumbnail\">"
 160         ;;                 file url-dir ref-file))
 161         (insert (format "<img alt=\"%s\" src=\"%s&size=thumbnail\">"
 162                         file ref-file))
 163         (insert "</a>\n")
 164         (setq prev-file (format "%d" i))
 165         (setq i (1+ i)
 166               ref-images (cdr ref-images)))
 167
 168       (when note
 169         (insert "<p>")
 170         (insert note))
 171
 172       (insert "
 173
 174 <hr>
 175 ")
 176       (if parent-url
 177           (insert (format "[<a href=\"%s\">Return</a>]\n" parent-url)))
 178
 179       (insert "
 180 </body>
 181 </html>
 182 ")
 183       (encode-coding-region (point-min)(point-max) www-page-coding-system)
 184       (princ (buffer-string))
 185       )))
 186
 187 (defun www-page-display-page (file &optional size image-root
 188                                     lang prev-file next-file)
 189   (if (stringp size)
 190       (setq size (intern size)))
 191   (if (stringp lang)
 192       (setq lang (intern lang)))
 193   (princ "Content-Type: text/html; charset=UTF-8
 194
 195 ")
 196   (with-temp-buffer
 197     (insert
 198      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
 199             \"http://www.w3.org/TR/html4/loose.dtd\">\n")
 200     (insert "<html")
 201     (if lang
 202         (insert (format " lang=\"%s\"" lang)))
 203     (insert " />\n")
 204     (insert "<head>\n")
 205     (insert (format "<title>%s</title>\n" file))
 206     (insert "</head>\n")
 207     (insert "<body>\n")
 208     ;; (insert (format "<h1>%s</h1>\n" file))
 209
 210     (let* ((desc-file (expand-file-name (concat file ".desc") image-root))
 211            (params
 212             (with-temp-buffer
 213               (when (file-exists-p desc-file)
 214                 (insert-file-contents desc-file)
 215                 (read (current-buffer)))))
 216            dir-desc-file
 217            image-file image-ref
 218            prev-file next-file
 219            prev-grade next-grade
 220            rest spec ret)
 221       (unless params
 222         (setq dir-desc-file
 223               (expand-file-name "dir.desc"
 224                                 (expand-file-name (file-name-directory file)
 225                                                   image-root)))
 226         (setq params
 227               (with-temp-buffer
 228                 (when (file-exists-p dir-desc-file)
 229                   (insert-file-contents dir-desc-file)
 230                   (read (current-buffer)))))
 231         (when (setq rest (assq 'files params))
 232           (setq rest (cdr rest)))
 233         (setq ret (file-name-nondirectory file))
 234         (while (and rest
 235                     (not (string= (car rest) ret)))
 236           (setq prev-file (car rest)
 237                 rest (cdr rest)))
 238         (setq next-file (car (cdr rest)))
 239         (if prev-file
 240             (setq params (list (cons 'prev-file prev-file))))
 241         (if next-file
 242             (setq params (cons (cons 'next-file next-file)
 243                                params)))
 244         (with-temp-buffer
 245           (insert (format "%S" params))
 246           ;; (princ "X-XEmacs-Message: ")
 247           (write-region (point-min)(point-max) desc-file)
 248           ;; (princ "\n")
 249           ))
 250       (if (setq image-ref (assq 'ref params))
 251           (setq image-ref (cdr image-ref))
 252         (setq image-file file))
 253       (if (setq prev-file (assq 'prev-file params))
 254           (setq prev-file (cdr prev-file)))
 255       (if (setq next-file (assq 'next-file params))
 256           (setq next-file (cdr next-file)))
 257       (setq rest www-page-size-specs)
 258       (while (and rest
 259                   (setq spec (car rest))
 260                   (not (eq (car spec) size)))
 261         (setq prev-grade (car spec)
 262               rest (cdr rest)))
 263       (setq next-grade (car (car (cdr rest))))
 264       (if prev-file
 265           (insert (format "<a href=\"page.cgi?%s%s.html.%s&size=%s\">"
 266                           (file-name-directory file) prev-file
 267                           (or lang 'en)
 268                           size)))
 269       (cond ((eq lang 'ja)
 270              (insert "[\e$BA0\e(B]")
 271              )
 272             (t
 273              (insert "[Previous]")
 274              ))
 275       (if prev-file
 276           (insert "</a>"))
 277       (insert "\n")
 278
 279       (if next-file
 280           (insert (format "<a href=\"page.cgi?%s%s.html.%s&size=%s\">"
 281                           (file-name-directory file) next-file
 282                           (or lang 'en)
 283                           size)))
 284       (cond ((eq lang 'ja)
 285              (insert "[\e$B<!\e(B]")
 286              )
 287             (t
 288              (insert "[Next]")
 289              ))
 290       (if next-file
 291           (insert "</a>"))
 292       (insert "\n")
 293
 294       (if prev-grade
 295           (insert (format "<a href=\"page.cgi?%s.html.%s&size=%s\">"
 296                           file
 297                           (or lang 'en)
 298                           prev-grade)))
 299       (cond ((eq lang 'ja)
 300              (insert "[\e$B=L>.\e(B]")
 301              )
 302             (t
 303              (insert "[Smaller]")
 304              ))
 305       (if prev-grade
 306           (insert "</a>"))
 307       (insert "\n")
 308
 309       (if next-grade
 310           (insert (format "<a href=\"page.cgi?%s.html.%s&size=%s\">"
 311                           file
 312                           (or lang 'en)
 313                           next-grade)))
 314       (cond ((eq lang 'ja)
 315              (insert "[\e$B3HBg\e(B]")
 316              )
 317             (t
 318              (insert "[Larger]")
 319              ))
 320       (if next-grade
 321           (insert "</a>"))
 322       (insert "\n")
 323
 324       (insert "
 325 <hr>
 326 ")
 327       (if next-file
 328           (insert (format "<a href=\"page.cgi?%s%s.html.%s&size=%s\">"
 329                           (file-name-directory file) next-file
 330                           (or lang 'en)
 331                           size)))
 332       (insert
 333        (if image-ref
 334            (format "<img alt=\"%s\" src=\"%s&size=%s\">"
 335                    file image-ref size)
 336          (format "<img alt=\"%s\" src=\"page.cgi?%s&size=%s\">"
 337                  file image-file size)))
 338       (if next-file
 339           (insert "</a>"))
 340       (insert "
 341 <hr>
 342
 343 ")
 344       (insert
 345        (format "<a href=\"page.cgi?%s&lang=%s&size=%s\">[index]</a>"
 346                (file-name-directory file)
 347                (or lang 'en)
 348                size))
 349       (insert "
 350 </body>
 351 </html>
 352 "))
 353     (encode-coding-region (point-min)(point-max) www-page-coding-system)
 354     (princ (buffer-string))
 355     ))
 356
 357 (defun www-page-display-image (file &optional size image-root)
 358   (setq file (expand-file-name file image-root))
 359   (let (file-dir file-name
 360         resized-file resized-dir
 361         spec)
 362     (cond
 363      (size
 364       (setq file-dir (file-name-directory file)
 365             file-name (file-name-nondirectory file))
 366       (setq resized-file
 367             (expand-file-name
 368              file-name
 369              (setq resized-dir
 370                    (expand-file-name
 371                     size file-dir))))
 372       (unless (file-exists-p resized-file)
 373         (setq size (intern size))
 374         (if (setq spec (assq size www-page-size-specs))
 375             (progn
 376               (condition-case nil
 377                   (unless (file-exists-p resized-dir)
 378                     (make-directory resized-dir))
 379                 (error nil))
 380               (call-process
 381                "convert" nil nil nil
 382                "-resize" (format "%dx%d>" (nth 1 spec)(nth 2 spec))
 383                file resized-file)
 384               )
 385           (setq resized-file file)))
 386       ;; (princ resized-file)
 387       (setq file resized-file)
 388       )
 389      (t
 390       ;; (princ file)
 391       ))
 392     (princ (format "Content-Type: %s"
 393                    (with-temp-buffer
 394                      (call-process
 395                       "file"
 396                       nil t t
 397                       "-b" "--mime" file)
 398                      (insert "\n")
 399                      (let ((coding-system-for-read 'binary)
 400                            (coding-system-for-write 'binary))
 401                        (insert-file-contents-literally file))
 402                      (buffer-string))))))
 403
 404 (defun www-page-batch-get ()
 405   ;; (set-coding-priority-list
 406   ;;  '(iso-7 iso-8-2 utf-8 big5 shift-jis
 407   ;;          iso-8-designate iso-8-1 iso-lock-shift no-conversion))
 408   ;; (set-coding-category-system 'utf-8 'utf-8-jp)
 409   (let (target params method size key image-root lang ret)
 410     (let ((rest (car command-line-args-left))
 411           arg val)
 412       (if rest
 413           (setq rest (split-string rest "&")))
 414       (setq target (car rest)
 415             rest (cdr rest))
 416       (while rest
 417         (when (and (string-match "=" (setq arg (car rest)))
 418                    (> (length (setq val (substring arg (match-end 0)))) 0))
 419           (setq key (substring arg 0 (match-beginning 0)))
 420           (set-alist 'params
 421                      key
 422                      (cons (decode-url-string val www-page-coding-system)
 423                            (cdr (assoc key params)))))
 424         (setq rest (cdr rest))))
 425     (setq method
 426           (cond
 427            ((string-match "\\.html\\(\\.\\([a-z]+\\)\\)?$" target)
 428             (setq lang (match-string 2 target))
 429             (setq target (substring target 0 (match-beginning 0)))
 430             (cond ((string= (file-name-nondirectory
 431                              ;; (substring target 0 (match-beginning 0))
 432                              target
 433                              )
 434                             "index")
 435                    (setq target (file-name-directory target))
 436                    'dir)
 437                   (t
 438                    'page))
 439             )
 440            ((or (string= (file-name-nondirectory target) "")
 441                 (null (file-name-extension target)))
 442             'dir)))
 443     ;; (setq file (car (cdr (assoc "file" params))))
 444     (setq size (car (cdr (assoc "size" params))))
 445     (if (setq ret (cdr (assoc "lang" params)))
 446         (setq lang (car ret)))
 447     (setq command-line-args-left (cdr command-line-args-left))
 448     (setq image-root (or (car command-line-args-left)
 449                          (expand-file-name
 450                           www-page-default-base-directory
 451                           default-directory)))
 452     (setq command-line-args-left (cdr command-line-args-left))
 453     (cond ((eq method 'dir)
 454            (www-page-display-thumbnails target size image-root lang)
 455            )
 456           ((eq method 'page)
 457            (www-page-display-page target size image-root lang)
 458            )
 459           (t
 460            (www-page-display-image target size image-root)
 461            )
 462           )))
 463
 464
 465 (provide 'www-page)
 466
 467 ;;; www-page.el ends here