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