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