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