www-page.el

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