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     (if (file-exists-p (expand-file-name file image-root))
 211         (let* ((desc-file (expand-file-name (concat file ".desc") image-root))
 212                (params
 213                 (with-temp-buffer
 214                   (when (file-exists-p desc-file)
 215                     (insert-file-contents desc-file)
 216                     (read (current-buffer)))))
 217                dir-desc-file
 218                image-file image-ref
 219                prev-file next-file
 220                prev-grade next-grade
 221                rest spec ret)
 222           (unless params
 223             (setq dir-desc-file
 224                   (expand-file-name "dir.desc"
 225                                     (expand-file-name (file-name-directory file)
 226                                                       image-root)))
 227             (setq params
 228                   (with-temp-buffer
 229                     (when (file-exists-p dir-desc-file)
 230                       (insert-file-contents dir-desc-file)
 231                       (read (current-buffer)))))
 232             (when (setq rest (assq 'files params))
 233               (setq rest (cdr rest)))
 234             (setq ret (file-name-nondirectory file))
 235             (while (and rest
 236                         (not (string= (car rest) ret)))
 237               (setq prev-file (car rest)
 238                     rest (cdr rest)))
 239             (setq next-file (car (cdr rest)))
 240             (if prev-file
 241                 (setq params (list (cons 'prev-file prev-file))))
 242             (if next-file
 243                 (setq params (cons (cons 'next-file next-file)
 244                                    params)))
 245             (with-temp-buffer
 246               (insert (format "%S" params))
 247               ;; (princ "X-XEmacs-Message: ")
 248               (write-region (point-min)(point-max) desc-file)
 249               ;; (princ "\n")
 250               ))
 251           (if (setq image-ref (assq 'ref params))
 252               (setq image-ref (cdr image-ref))
 253             (setq image-file file))
 254           (if (setq prev-file (assq 'prev-file params))
 255               (setq prev-file (cdr prev-file)))
 256           (if (setq next-file (assq 'next-file params))
 257               (setq next-file (cdr next-file)))
 258           (setq rest www-page-size-specs)
 259           (while (and rest
 260                       (setq spec (car rest))
 261                       (not (eq (car spec) size)))
 262             (setq prev-grade (car spec)
 263                   rest (cdr rest)))
 264           (setq next-grade (car (car (cdr rest))))
 265           (if prev-file
 266               (insert (format "<a href=\"page.cgi?%s%s.html.%s&size=%s\">"
 267                               (file-name-directory file) prev-file
 268                               (or lang 'en)
 269                               size)))
 270           (cond ((eq lang 'ja)
 271                  (insert "[\e$BA0\e(B]")
 272                  )
 273                 (t
 274                  (insert "[Previous]")
 275                  ))
 276           (if prev-file
 277               (insert "</a>"))
 278           (insert "\n")
 279
 280           (if next-file
 281               (insert (format "<a href=\"page.cgi?%s%s.html.%s&size=%s\">"
 282                               (file-name-directory file) next-file
 283                               (or lang 'en)
 284                               size)))
 285           (cond ((eq lang 'ja)
 286                  (insert "[\e$B<!\e(B]")
 287                  )
 288                 (t
 289                  (insert "[Next]")
 290                  ))
 291           (if next-file
 292               (insert "</a>"))
 293           (insert "\n")
 294
 295           (if prev-grade
 296               (insert (format "<a href=\"page.cgi?%s.html.%s&size=%s\">"
 297                               file
 298                               (or lang 'en)
 299                               prev-grade)))
 300           (cond ((eq lang 'ja)
 301                  (insert "[\e$B=L>.\e(B]")
 302                  )
 303                 (t
 304                  (insert "[Smaller]")
 305                  ))
 306           (if prev-grade
 307               (insert "</a>"))
 308           (insert "\n")
 309
 310           (if next-grade
 311               (insert (format "<a href=\"page.cgi?%s.html.%s&size=%s\">"
 312                               file
 313                               (or lang 'en)
 314                               next-grade)))
 315           (cond ((eq lang 'ja)
 316                  (insert "[\e$B3HBg\e(B]")
 317                  )
 318                 (t
 319                  (insert "[Larger]")
 320                  ))
 321           (if next-grade
 322               (insert "</a>"))
 323           (insert "\n")
 324
 325           (insert "
 326 <hr>
 327 ")
 328           (if next-file
 329               (insert (format "<a href=\"page.cgi?%s%s.html.%s&size=%s\">"
 330                               (file-name-directory file) next-file
 331                               (or lang 'en)
 332                               size)))
 333           (insert
 334            (if image-ref
 335                (format "<img alt=\"%s\" src=\"%s&size=%s\">"
 336                        file image-ref size)
 337              (format "<img alt=\"%s\" src=\"page.cgi?%s&size=%s\">"
 338                      file image-file size)))
 339           (if next-file
 340               (insert "</a>"))
 341           )
 342       (insert "<p>")
 343       (insert (format
 344                (cond
 345                 ((eq lang 'ja)
 346                  "\e$B2hA|%U%!%$%k\e(B %s \e$B$,8+IU$+$j$^$;$s!#\e(B\n")
 347                 (t
 348                  "Image file %s is not found.\n"))
 349                file))
 350       )
 351     (insert "
 352 <hr>
 353
 354 ")
 355     (insert
 356      (format "<a href=\"page.cgi?%s&lang=%s&size=%s\">[index]</a>"
 357              (file-name-directory file)
 358              (or lang 'en)
 359              size))
 360     (insert "
 361 </body>
 362 </html>
 363 ")
 364     (encode-coding-region (point-min)(point-max) www-page-coding-system)
 365     (princ (buffer-string))
 366     ))
 367
 368 (defun www-page-display-image (file &optional size image-root)
 369   (setq file (expand-file-name file image-root))
 370   (let (file-dir file-name
 371         resized-file resized-dir
 372         spec)
 373     (cond
 374      (size
 375       (setq file-dir (file-name-directory file)
 376             file-name (file-name-nondirectory file))
 377       (setq resized-file
 378             (expand-file-name
 379              file-name
 380              (setq resized-dir
 381                    (expand-file-name
 382                     size file-dir))))
 383       (unless (file-exists-p resized-file)
 384         (setq size (intern size))
 385         (if (setq spec (assq size www-page-size-specs))
 386             (progn
 387               (condition-case nil
 388                   (unless (file-exists-p resized-dir)
 389                     (make-directory resized-dir))
 390                 (error nil))
 391               (call-process
 392                "convert" nil nil nil
 393                "-resize" (format "%dx%d>" (nth 1 spec)(nth 2 spec))
 394                file resized-file)
 395               )
 396           (setq resized-file file)))
 397       ;; (princ resized-file)
 398       (setq file resized-file)
 399       )
 400      (t
 401       ;; (princ file)
 402       ))
 403     (princ (format "Content-Type: %s"
 404                    (with-temp-buffer
 405                      (call-process
 406                       "file"
 407                       nil t t
 408                       "-b" "--mime" file)
 409                      (insert "\n")
 410                      (let ((coding-system-for-read 'binary)
 411                            (coding-system-for-write 'binary))
 412                        (insert-file-contents-literally file))
 413                      (buffer-string))))))
 414
 415 (defun www-page-batch-get ()
 416   ;; (set-coding-priority-list
 417   ;;  '(iso-7 iso-8-2 utf-8 big5 shift-jis
 418   ;;          iso-8-designate iso-8-1 iso-lock-shift no-conversion))
 419   ;; (set-coding-category-system 'utf-8 'utf-8-jp)
 420   (let (target params method size key image-root lang ret)
 421     (let ((rest (car command-line-args-left))
 422           arg val)
 423       (if rest
 424           (setq rest (split-string rest "&")))
 425       (setq target (car rest)
 426             rest (cdr rest))
 427       (while rest
 428         (when (and (string-match "=" (setq arg (car rest)))
 429                    (> (length (setq val (substring arg (match-end 0)))) 0))
 430           (setq key (substring arg 0 (match-beginning 0)))
 431           (set-alist 'params
 432                      key
 433                      (cons (decode-url-string val www-page-coding-system)
 434                            (cdr (assoc key params)))))
 435         (setq rest (cdr rest))))
 436     (setq method
 437           (cond
 438            ((string-match "\\.html\\(\\.\\([a-z]+\\)\\)?$" target)
 439             (setq lang (match-string 2 target))
 440             (setq target (substring target 0 (match-beginning 0)))
 441             (cond ((string= (file-name-nondirectory
 442                              ;; (substring target 0 (match-beginning 0))
 443                              target
 444                              )
 445                             "index")
 446                    (setq target (file-name-directory target))
 447                    'dir)
 448                   (t
 449                    'page))
 450             )
 451            ((or (string= (file-name-nondirectory target) "")
 452                 (null (file-name-extension target)))
 453             'dir)))
 454     ;; (setq file (car (cdr (assoc "file" params))))
 455     (setq size (car (cdr (assoc "size" params))))
 456     (if (setq ret (cdr (assoc "lang" params)))
 457         (setq lang (car ret)))
 458     (setq command-line-args-left (cdr command-line-args-left))
 459     (setq image-root (or (car command-line-args-left)
 460                          (expand-file-name
 461                           www-page-default-base-directory
 462                           default-directory)))
 463     (setq command-line-args-left (cdr command-line-args-left))
 464     (cond ((eq method 'dir)
 465            (www-page-display-thumbnails target size image-root lang)
 466            )
 467           ((eq method 'page)
 468            (www-page-display-page target size image-root lang)
 469            )
 470           (t
 471            (www-page-display-image target size image-root)
 472            )
 473           )))
 474
 475
 476 (provide 'www-page)
 477
 478 ;;; www-page.el ends here