www-page.el

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