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